source/cluster/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 'sizesclu.dat'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.SHIELD'
  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 continue
  53 C      write(iout,*) "shield_mode",shield_mode,ethetacnstr
  54       if (shield_mode.eq.1) then
  55        call set_shield_fac
  56       else if  (shield_mode.eq.2) then
  57        call set_shield_fac2
  58       endif
  59       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  60 C
  61 C Calculate excluded-volume interaction energy between peptide groups
  62 C and side chains.
  63 C
  64       call escp(evdw2,evdw2_14)
  65 c
  66 c Calculate the bond-stretching energy
  67 c
  68       call ebond(estr)
  69 c      write (iout,*) "estr",estr
  70 C
  71 C Calculate the disulfide-bridge and other energy and the contributions
  72 C from other distance constraints.
  73 cd    print *,'Calling EHPB'
  74       call edis(ehpb)
  75 cd    print *,'EHPB exitted succesfully.'
  76 C
  77 C Calculate the virtual-bond-angle energy.
  78 C
  79       call ebend(ebe,ethetacnstr)
  80 cd    print *,'Bend energy finished.'
  81 C
  82 C Calculate the SC local energy.
  83 C
  84       call esc(escloc)
  85 cd    print *,'SCLOC energy finished.'
  86 C
  87 C Calculate the virtual-bond torsional energy.
  88 C
  89 cd    print *,'nterm=',nterm
  90       call etor(etors,edihcnstr,fact(1))
  91 C
  92 C 6/23/01 Calculate double-torsional energy
  93 C
  94       call etor_d(etors_d,fact(2))
  95 C
  96 C 21/5/07 Calculate local sicdechain correlation energy
  97 C
  98       call eback_sc_corr(esccor)
  99
 100       if (wliptran.gt.0) then
 101         call Eliptransfer(eliptran)
 102       endif
 103
 104 C
 105 C 12/1/95 Multi-body terms
 106 C
 107       n_corr=0
 108       n_corr1=0
 109       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 110      &    .or. wturn6.gt.0.0d0) then
 111 c         print *,"calling multibody_eello"
 112          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 113 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 114 c         print *,ecorr,ecorr5,ecorr6,eturn6
 115       else
 116          ecorr=0.0d0
 117          ecorr5=0.0d0
 118          ecorr6=0.0d0
 119          eturn6=0.0d0
 120       endif
 121       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 122          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 123       endif
 124       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 125         call e_saxs(Esaxs_constr)
 126 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 127       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 128         call e_saxsC(Esaxs_constr)
 129 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 130       else
 131         Esaxs_constr = 0.0d0
 132       endif
 133 c      write(iout,*) "TEST_ENE",constr_homology
 134       if (constr_homology.ge.1) then
 135         call e_modeller(ehomology_constr)
 136       else
 137         ehomology_constr=0.0d0
 138       endif
 139 c      write(iout,*) "TEST_ENE",ehomology_constr
 140
 141
 142 c      write (iout,*) "ft(6)",fact(6),wliptran,eliptran
 143 #ifdef SPLITELE
 144       if (shield_mode.gt.0) then
 145       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 146      & +welec*fact(1)*ees
 147      & +fact(1)*wvdwpp*evdw1
 148      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 149      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 150      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 151      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 152      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 153      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 154      & +wliptran*eliptran+wsaxs*esaxs_constr
 155       else
 156       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 157      & +wvdwpp*evdw1
 158      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 159      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 160      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 161      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 162      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 163      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 164      & +wliptran*eliptran+wsaxs*esaxs_constr
 165       endif
 166 #else
 167       if (shield_mode.gt.0) then
 168       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 169      & +welec*fact(1)*(ees+evdw1)
 170      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 171      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 172      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 173      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 174      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 175      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 176      & +wliptran*eliptran+wsaxs*esaxs_constr
 177       else
 178       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 179      & +welec*fact(1)*(ees+evdw1)
 180      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 181      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 182      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 183      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 184      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 185      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 186      & +wliptran*eliptran+wsaxs*esaxs_constr
 187       endif
 188 #endif
 189
 190       energia(0)=etot
 191       energia(1)=evdw
 192 #ifdef SCP14
 193       energia(2)=evdw2-evdw2_14
 194       energia(17)=evdw2_14
 195 #else
 196       energia(2)=evdw2
 197       energia(17)=0.0d0
 198 #endif
 199 #ifdef SPLITELE
 200       energia(3)=ees
 201       energia(16)=evdw1
 202 #else
 203       energia(3)=ees+evdw1
 204       energia(16)=0.0d0
 205 #endif
 206       energia(4)=ecorr
 207       energia(5)=ecorr5
 208       energia(6)=ecorr6
 209       energia(7)=eel_loc
 210       energia(8)=eello_turn3
 211       energia(9)=eello_turn4
 212       energia(10)=eturn6
 213       energia(11)=ebe
 214       energia(12)=escloc
 215       energia(13)=etors
 216       energia(14)=etors_d
 217       energia(15)=ehpb
 218       energia(18)=estr
 219       energia(19)=esccor
 220       energia(20)=edihcnstr
 221       energia(24)=ehomology_constr
 222       energia(21)=evdw_t
 223       energia(25)=Esaxs_constr
 224 c      energia(24)=ethetacnstr
 225       energia(22)=eliptran
 226 c detecting NaNQ
 227 #ifdef ISNAN
 228 #ifdef AIX
 229       if (isnan(etot).ne.0) energia(0)=1.0d+99
 230 #else
 231       if (isnan(etot)) energia(0)=1.0d+99
 232 #endif
 233 #else
 234       i=0
 235 #ifdef WINPGI
 236       idumm=proc_proc(etot,i)
 237 #else
 238       call proc_proc(etot,i)
 239 #endif
 240       if(i.eq.1)energia(0)=1.0d+99
 241 #endif
 242 #ifdef MPL
 243 c     endif
 244 #endif
 245       if (calc_grad) then
 246 C
 247 C Sum up the components of the Cartesian gradient.
 248 C
 249 #ifdef SPLITELE
 250       do i=1,nct
 251         do j=1,3
 252       if (shield_mode.eq.0) then
 253           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 254      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 255      &                wbond*gradb(j,i)+
 256      &                wstrain*ghpbc(j,i)+
 257      &                wcorr*fact(3)*gradcorr(j,i)+
 258      &                wel_loc*fact(2)*gel_loc(j,i)+
 259      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 260      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 261      &                wcorr5*fact(4)*gradcorr5(j,i)+
 262      &                wcorr6*fact(5)*gradcorr6(j,i)+
 263      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 264      &                wsccor*fact(2)*gsccorc(j,i)
 265      &               +wliptran*gliptranc(j,i)
 266           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 267      &                  wbond*gradbx(j,i)+
 268      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 269      &                  wsccor*fact(2)*gsccorx(j,i)
 270      &                 +wliptran*gliptranx(j,i)
 271         else
 272           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 273      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 274      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 275      &                wbond*gradb(j,i)+
 276      &                wstrain*ghpbc(j,i)+
 277      &                wcorr*fact(3)*gradcorr(j,i)+
 278      &                wel_loc*fact(2)*gel_loc(j,i)+
 279      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 280      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 281      &                wcorr5*fact(4)*gradcorr5(j,i)+
 282      &                wcorr6*fact(5)*gradcorr6(j,i)+
 283      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 284      &                wsccor*fact(2)*gsccorc(j,i)
 285      &               +wliptran*gliptranc(j,i)
 286      &                 +welec*gshieldc(j,i)
 287      &                 +welec*gshieldc_loc(j,i)
 288      &                 +wcorr*gshieldc_ec(j,i)
 289      &                 +wcorr*gshieldc_loc_ec(j,i)
 290      &                 +wturn3*gshieldc_t3(j,i)
 291      &                 +wturn3*gshieldc_loc_t3(j,i)
 292      &                 +wturn4*gshieldc_t4(j,i)
 293      &                 +wturn4*gshieldc_loc_t4(j,i)
 294      &                 +wel_loc*gshieldc_ll(j,i)
 295      &                 +wel_loc*gshieldc_loc_ll(j,i)
 296
 297           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 298      &                 +fact(1)*wscp*gradx_scp(j,i)+
 299      &                  wbond*gradbx(j,i)+
 300      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 301      &                  wsccor*fact(2)*gsccorx(j,i)
 302      &                 +wliptran*gliptranx(j,i)
 303      &                 +welec*gshieldx(j,i)
 304      &                 +wcorr*gshieldx_ec(j,i)
 305      &                 +wturn3*gshieldx_t3(j,i)
 306      &                 +wturn4*gshieldx_t4(j,i)
 307      &                 +wel_loc*gshieldx_ll(j,i)
 308
 309
 310         endif
 311         enddo
 312 #else
 313        do i=1,nct
 314         do j=1,3
 315                 if (shield_mode.eq.0) then
 316           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 317      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 318      &                wbond*gradb(j,i)+
 319      &                wcorr*fact(3)*gradcorr(j,i)+
 320      &                wel_loc*fact(2)*gel_loc(j,i)+
 321      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 322      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 323      &                wcorr5*fact(4)*gradcorr5(j,i)+
 324      &                wcorr6*fact(5)*gradcorr6(j,i)+
 325      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 326      &                wsccor*fact(2)*gsccorc(j,i)
 327      &               +wliptran*gliptranc(j,i)
 328           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 329      &                  wbond*gradbx(j,i)+
 330      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 331      &                  wsccor*fact(1)*gsccorx(j,i)
 332      &                 +wliptran*gliptranx(j,i)
 333               else
 334           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 335      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 336      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 337      &                wbond*gradb(j,i)+
 338      &                wcorr*fact(3)*gradcorr(j,i)+
 339      &                wel_loc*fact(2)*gel_loc(j,i)+
 340      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 341      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 342      &                wcorr5*fact(4)*gradcorr5(j,i)+
 343      &                wcorr6*fact(5)*gradcorr6(j,i)+
 344      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 345      &                wsccor*fact(2)*gsccorc(j,i)
 346      &               +wliptran*gliptranc(j,i)
 347           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 348      &                  fact(1)*wscp*gradx_scp(j,i)+
 349      &                  wbond*gradbx(j,i)+
 350      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 351      &                  wsccor*fact(1)*gsccorx(j,i)
 352      &                 +wliptran*gliptranx(j,i)
 353          endif
 354         enddo
 355 #endif
 356       enddo
 357
 358
 359       do i=1,nres-3
 360         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 361      &   +wcorr5*fact(4)*g_corr5_loc(i)
 362      &   +wcorr6*fact(5)*g_corr6_loc(i)
 363      &   +wturn4*fact(3)*gel_loc_turn4(i)
 364      &   +wturn3*fact(2)*gel_loc_turn3(i)
 365      &   +wturn6*fact(5)*gel_loc_turn6(i)
 366      &   +wel_loc*fact(2)*gel_loc_loc(i)
 367 c     &   +wsccor*fact(1)*gsccor_loc(i)
 368 c ROZNICA Z WHAMem
 369       enddo
 370       endif
 371       if (dyn_ss) call dyn_set_nss
 372       return
 373       end
 374 C------------------------------------------------------------------------
 375       subroutine enerprint(energia,fact)
 376       implicit real*8 (a-h,o-z)
 377       include 'DIMENSIONS'
 378       include 'sizesclu.dat'
 379       include 'COMMON.IOUNITS'
 380       include 'COMMON.FFIELD'
 381       include 'COMMON.SBRIDGE'
 382       double precision energia(0:max_ene),fact(6)
 383       etot=energia(0)
 384       evdw=energia(1)+fact(6)*energia(21)
 385 #ifdef SCP14
 386       evdw2=energia(2)+energia(17)
 387 #else
 388       evdw2=energia(2)
 389 #endif
 390       ees=energia(3)
 391 #ifdef SPLITELE
 392       evdw1=energia(16)
 393 #endif
 394       ecorr=energia(4)
 395       ecorr5=energia(5)
 396       ecorr6=energia(6)
 397       eel_loc=energia(7)
 398       eello_turn3=energia(8)
 399       eello_turn4=energia(9)
 400       eello_turn6=energia(10)
 401       ebe=energia(11)
 402       escloc=energia(12)
 403       etors=energia(13)
 404       etors_d=energia(14)
 405       ehpb=energia(15)
 406       esccor=energia(19)
 407       edihcnstr=energia(20)
 408       estr=energia(18)
 409       ehomology_constr=energia(24)
 410       esaxs_constr=energia(25)
 411 c      ethetacnstr=energia(24)
 412 #ifdef SPLITELE
 413       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 414      &  wvdwpp,
 415      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 416      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 417      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 418      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 419      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 420      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,
 421      &  wsaxs*esaxs_constr,ebr*nss,etot
 422    10 format (/'Virtual-chain energies:'//
 423      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 424      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 425      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 426      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 427      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 428      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 429      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 430      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 431      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 432      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 433      & ' (SS bridges & dist. cnstr.)'/
 434      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 435      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 436      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 437      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 438      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 439      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 440      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 441      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 442      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 443      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 444      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
 445      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 446      & 'ETOT=  ',1pE16.6,' (total)')
 447 #else
 448       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 449      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 450      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 451      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 452      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 453      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 454      &  edihcnstr,ehomology_constr,esaxs_constr*wsaxs,ebr*nss,
 455      &  etot
 456    10 format (/'Virtual-chain energies:'//
 457      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 458      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 459      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 460      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 461      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 462      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 463      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 464      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 465      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 466      & ' (SS bridges & dist. cnstr.)'/
 467      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 468      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 469      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 470      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 471      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 472      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 473      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 474      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 475      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 476      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 477      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
 478      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 479      & 'ETOT=  ',1pE16.6,' (total)')
 480 #endif
 481       return
 482       end
 483 C-----------------------------------------------------------------------
 484       subroutine elj(evdw,evdw_t)
 485 C
 486 C This subroutine calculates the interaction energy of nonbonded side chains
 487 C assuming the LJ potential of interaction.
 488 C
 489       implicit real*8 (a-h,o-z)
 490       include 'DIMENSIONS'
 491       include 'sizesclu.dat'
 492       include "DIMENSIONS.COMPAR"
 493       parameter (accur=1.0d-10)
 494       include 'COMMON.GEO'
 495       include 'COMMON.VAR'
 496       include 'COMMON.LOCAL'
 497       include 'COMMON.CHAIN'
 498       include 'COMMON.DERIV'
 499       include 'COMMON.INTERACT'
 500       include 'COMMON.TORSION'
 501       include 'COMMON.SBRIDGE'
 502       include 'COMMON.NAMES'
 503       include 'COMMON.IOUNITS'
 504       include 'COMMON.CONTACTS'
 505       dimension gg(3)
 506       integer icant
 507       external icant
 508 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 509 c ROZNICA DODANE Z WHAM
 510 c      do i=1,210
 511 c        do j=1,2
 512 c          eneps_temp(j,i)=0.0d0
 513 c        enddo
 514 c      enddo
 515 cROZNICA
 516
 517       evdw=0.0D0
 518       evdw_t=0.0d0
 519       do i=iatsc_s,iatsc_e
 520         itypi=iabs(itype(i))
 521         if (itypi.eq.ntyp1) cycle
 522         itypi1=iabs(itype(i+1))
 523         xi=c(1,nres+i)
 524         yi=c(2,nres+i)
 525         zi=c(3,nres+i)
 526 C Change 12/1/95
 527         num_conti=0
 528 C
 529 C Calculate SC interaction energy.
 530 C
 531         do iint=1,nint_gr(i)
 532 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 533 cd   &                  'iend=',iend(i,iint)
 534           do j=istart(i,iint),iend(i,iint)
 535             itypj=iabs(itype(j))
 536             if (itypj.eq.ntyp1) cycle
 537             xj=c(1,nres+j)-xi
 538             yj=c(2,nres+j)-yi
 539             zj=c(3,nres+j)-zi
 540 C Change 12/1/95 to calculate four-body interactions
 541             rij=xj*xj+yj*yj+zj*zj
 542             rrij=1.0D0/rij
 543 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 544             eps0ij=eps(itypi,itypj)
 545             fac=rrij**expon2
 546             e1=fac*fac*aa
 547             e2=fac*bb
 548             evdwij=e1+e2
 549             ij=icant(itypi,itypj)
 550 c ROZNICA z WHAM
 551 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 552 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 553 c
 554
 555 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 556 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 557 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 558 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 559 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 560 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 561             if (bb.gt.0.0d0) then
 562               evdw=evdw+evdwij
 563             else
 564               evdw_t=evdw_t+evdwij
 565             endif
 566             if (calc_grad) then
 567 C
 568 C Calculate the components of the gradient in DC and X
 569 C
 570             fac=-rrij*(e1+evdwij)
 571             gg(1)=xj*fac
 572             gg(2)=yj*fac
 573             gg(3)=zj*fac
 574             do k=1,3
 575               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 576               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 577             enddo
 578             do k=i,j-1
 579               do l=1,3
 580                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 581               enddo
 582             enddo
 583             endif
 584 C
 585 C 12/1/95, revised on 5/20/97
 586 C
 587 C Calculate the contact function. The ith column of the array JCONT will
 588 C contain the numbers of atoms that make contacts with the atom I (of numbers
 589 C greater than I). The arrays FACONT and GACONT will contain the values of
 590 C the contact function and its derivative.
 591 C
 592 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 593 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 594 C Uncomment next line, if the correlation interactions are contact function only
 595             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 596               rij=dsqrt(rij)
 597               sigij=sigma(itypi,itypj)
 598               r0ij=rs0(itypi,itypj)
 599 C
 600 C Check whether the SC's are not too far to make a contact.
 601 C
 602               rcut=1.5d0*r0ij
 603               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 604 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 605 C
 606               if (fcont.gt.0.0D0) then
 607 C If the SC-SC distance if close to sigma, apply spline.
 608 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 609 cAdam &             fcont1,fprimcont1)
 610 cAdam           fcont1=1.0d0-fcont1
 611 cAdam           if (fcont1.gt.0.0d0) then
 612 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 613 cAdam             fcont=fcont*fcont1
 614 cAdam           endif
 615 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 616 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 617 cga             do k=1,3
 618 cga               gg(k)=gg(k)*eps0ij
 619 cga             enddo
 620 cga             eps0ij=-evdwij*eps0ij
 621 C Uncomment for AL's type of SC correlation interactions.
 622 cadam           eps0ij=-evdwij
 623                 num_conti=num_conti+1
 624                 jcont(num_conti,i)=j
 625                 facont(num_conti,i)=fcont*eps0ij
 626                 fprimcont=eps0ij*fprimcont/rij
 627                 fcont=expon*fcont
 628 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 629 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 630 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 631 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 632                 gacont(1,num_conti,i)=-fprimcont*xj
 633                 gacont(2,num_conti,i)=-fprimcont*yj
 634                 gacont(3,num_conti,i)=-fprimcont*zj
 635 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 636 cd              write (iout,'(2i3,3f10.5)')
 637 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 638               endif
 639             endif
 640           enddo      ! j
 641         enddo        ! iint
 642 C Change 12/1/95
 643         num_cont(i)=num_conti
 644       enddo          ! i
 645       if (calc_grad) then
 646       do i=1,nct
 647         do j=1,3
 648           gvdwc(j,i)=expon*gvdwc(j,i)
 649           gvdwx(j,i)=expon*gvdwx(j,i)
 650         enddo
 651       enddo
 652       endif
 653 C******************************************************************************
 654 C
 655 C                              N O T E !!!
 656 C
 657 C To save time, the factor of EXPON has been extracted from ALL components
 658 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 659 C use!
 660 C
 661 C******************************************************************************
 662       return
 663       end
 664 C-----------------------------------------------------------------------------
 665       subroutine eljk(evdw,evdw_t)
 666 C
 667 C This subroutine calculates the interaction energy of nonbonded side chains
 668 C assuming the LJK potential of interaction.
 669 C
 670       implicit real*8 (a-h,o-z)
 671       include 'DIMENSIONS'
 672       include 'sizesclu.dat'
 673       include "DIMENSIONS.COMPAR"
 674       include 'COMMON.GEO'
 675       include 'COMMON.VAR'
 676       include 'COMMON.LOCAL'
 677       include 'COMMON.CHAIN'
 678       include 'COMMON.DERIV'
 679       include 'COMMON.INTERACT'
 680       include 'COMMON.IOUNITS'
 681       include 'COMMON.NAMES'
 682       dimension gg(3)
 683       logical scheck
 684       integer icant
 685       external icant
 686 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 687       evdw=0.0D0
 688       evdw_t=0.0d0
 689       do i=iatsc_s,iatsc_e
 690         itypi=iabs(itype(i))
 691         if (itypi.eq.ntyp1) cycle
 692         itypi1=iabs(itype(i+1))
 693         xi=c(1,nres+i)
 694         yi=c(2,nres+i)
 695         zi=c(3,nres+i)
 696 C
 697 C Calculate SC interaction energy.
 698 C
 699         do iint=1,nint_gr(i)
 700           do j=istart(i,iint),iend(i,iint)
 701             itypj=iabs(itype(j))
 702             if (itypj.eq.ntyp1) cycle
 703             xj=c(1,nres+j)-xi
 704             yj=c(2,nres+j)-yi
 705             zj=c(3,nres+j)-zi
 706             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 707             fac_augm=rrij**expon
 708             e_augm=augm(itypi,itypj)*fac_augm
 709             r_inv_ij=dsqrt(rrij)
 710             rij=1.0D0/r_inv_ij
 711             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 712             fac=r_shift_inv**expon
 713             e1=fac*fac*aa
 714             e2=fac*bb
 715             evdwij=e_augm+e1+e2
 716             ij=icant(itypi,itypj)
 717 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 718 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 719 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 720 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 721 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 722 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 723 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 724             if (bb.gt.0.0d0) then
 725               evdw=evdw+evdwij
 726             else
 727               evdw_t=evdw_t+evdwij
 728             endif
 729             if (calc_grad) then
 730 C
 731 C Calculate the components of the gradient in DC and X
 732 C
 733             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 734             gg(1)=xj*fac
 735             gg(2)=yj*fac
 736             gg(3)=zj*fac
 737             do k=1,3
 738               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 739               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 740             enddo
 741             do k=i,j-1
 742               do l=1,3
 743                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 744               enddo
 745             enddo
 746             endif
 747           enddo      ! j
 748         enddo        ! iint
 749       enddo          ! i
 750       if (calc_grad) then
 751       do i=1,nct
 752         do j=1,3
 753           gvdwc(j,i)=expon*gvdwc(j,i)
 754           gvdwx(j,i)=expon*gvdwx(j,i)
 755         enddo
 756       enddo
 757       endif
 758       return
 759       end
 760 C-----------------------------------------------------------------------------
 761       subroutine ebp(evdw,evdw_t)
 762 C
 763 C This subroutine calculates the interaction energy of nonbonded side chains
 764 C assuming the Berne-Pechukas potential of interaction.
 765 C
 766       implicit real*8 (a-h,o-z)
 767       include 'DIMENSIONS'
 768       include 'sizesclu.dat'
 769       include "DIMENSIONS.COMPAR"
 770       include 'COMMON.GEO'
 771       include 'COMMON.VAR'
 772       include 'COMMON.LOCAL'
 773       include 'COMMON.CHAIN'
 774       include 'COMMON.DERIV'
 775       include 'COMMON.NAMES'
 776       include 'COMMON.INTERACT'
 777       include 'COMMON.IOUNITS'
 778       include 'COMMON.CALC'
 779       common /srutu/ icall
 780 c     double precision rrsave(maxdim)
 781       logical lprn
 782       integer icant
 783       external icant
 784       evdw=0.0D0
 785       evdw_t=0.0d0
 786 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 787 c     if (icall.eq.0) then
 788 c       lprn=.true.
 789 c     else
 790         lprn=.false.
 791 c     endif
 792       ind=0
 793       do i=iatsc_s,iatsc_e
 794         itypi=iabs(itype(i))
 795         if (itypi.eq.ntyp1) cycle
 796         itypi1=iabs(itype(i+1))
 797         xi=c(1,nres+i)
 798         yi=c(2,nres+i)
 799         zi=c(3,nres+i)
 800         dxi=dc_norm(1,nres+i)
 801         dyi=dc_norm(2,nres+i)
 802         dzi=dc_norm(3,nres+i)
 803         dsci_inv=vbld_inv(i+nres)
 804 C
 805 C Calculate SC interaction energy.
 806 C
 807         do iint=1,nint_gr(i)
 808           do j=istart(i,iint),iend(i,iint)
 809             ind=ind+1
 810             itypj=iabs(itype(j))
 811             if (itypj.eq.ntyp1) cycle
 812             dscj_inv=vbld_inv(j+nres)
 813             chi1=chi(itypi,itypj)
 814             chi2=chi(itypj,itypi)
 815             chi12=chi1*chi2
 816             chip1=chip(itypi)
 817             chip2=chip(itypj)
 818             chip12=chip1*chip2
 819             alf1=alp(itypi)
 820             alf2=alp(itypj)
 821             alf12=0.5D0*(alf1+alf2)
 822 C For diagnostics only!!!
 823 c           chi1=0.0D0
 824 c           chi2=0.0D0
 825 c           chi12=0.0D0
 826 c           chip1=0.0D0
 827 c           chip2=0.0D0
 828 c           chip12=0.0D0
 829 c           alf1=0.0D0
 830 c           alf2=0.0D0
 831 c           alf12=0.0D0
 832             xj=c(1,nres+j)-xi
 833             yj=c(2,nres+j)-yi
 834             zj=c(3,nres+j)-zi
 835             dxj=dc_norm(1,nres+j)
 836             dyj=dc_norm(2,nres+j)
 837             dzj=dc_norm(3,nres+j)
 838             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 839 cd          if (icall.eq.0) then
 840 cd            rrsave(ind)=rrij
 841 cd          else
 842 cd            rrij=rrsave(ind)
 843 cd          endif
 844             rij=dsqrt(rrij)
 845 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 846             call sc_angular
 847 C Calculate whole angle-dependent part of epsilon and contributions
 848 C to its derivatives
 849             fac=(rrij*sigsq)**expon2
 850             e1=fac*fac*aa
 851             e2=fac*bb
 852             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 853             eps2der=evdwij*eps3rt
 854             eps3der=evdwij*eps2rt
 855             evdwij=evdwij*eps2rt*eps3rt
 856             ij=icant(itypi,itypj)
 857             aux=eps1*eps2rt**2*eps3rt**2
 858             if (bb.gt.0.0d0) then
 859               evdw=evdw+evdwij
 860             else
 861               evdw_t=evdw_t+evdwij
 862             endif
 863             if (calc_grad) then
 864             if (lprn) then
 865             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 866             epsi=bb**2/aa
 867 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 868 cd     &        restyp(itypi),i,restyp(itypj),j,
 869 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 870 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 871 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 872 cd     &        evdwij
 873             endif
 874 C Calculate gradient components.
 875             e1=e1*eps1*eps2rt**2*eps3rt**2
 876             fac=-expon*(e1+evdwij)
 877             sigder=fac/sigsq
 878             fac=rrij*fac
 879 C Calculate radial part of the gradient
 880             gg(1)=xj*fac
 881             gg(2)=yj*fac
 882             gg(3)=zj*fac
 883 C Calculate the angular part of the gradient and sum add the contributions
 884 C to the appropriate components of the Cartesian gradient.
 885             call sc_grad
 886             endif
 887           enddo      ! j
 888         enddo        ! iint
 889       enddo          ! i
 890 c     stop
 891       return
 892       end
 893 C-----------------------------------------------------------------------------
 894       subroutine egb(evdw,evdw_t)
 895 C
 896 C This subroutine calculates the interaction energy of nonbonded side chains
 897 C assuming the Gay-Berne potential of interaction.
 898 C
 899       implicit real*8 (a-h,o-z)
 900       include 'DIMENSIONS'
 901       include 'sizesclu.dat'
 902       include "DIMENSIONS.COMPAR"
 903       include 'COMMON.GEO'
 904       include 'COMMON.VAR'
 905       include 'COMMON.LOCAL'
 906       include 'COMMON.CHAIN'
 907       include 'COMMON.DERIV'
 908       include 'COMMON.NAMES'
 909       include 'COMMON.INTERACT'
 910       include 'COMMON.IOUNITS'
 911       include 'COMMON.CALC'
 912       include 'COMMON.SBRIDGE'
 913       logical lprn
 914       common /srutu/icall
 915       integer icant
 916       external icant
 917       integer xshift,yshift,zshift
 918       logical energy_dec /.false./
 919 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 920       evdw=0.0D0
 921       evdw_t=0.0d0
 922       lprn=.false.
 923 c      if (icall.gt.0) lprn=.true.
 924       ind=0
 925       do i=iatsc_s,iatsc_e
 926         itypi=iabs(itype(i))
 927         if (itypi.eq.ntyp1) cycle
 928         itypi1=iabs(itype(i+1))
 929         xi=c(1,nres+i)
 930         yi=c(2,nres+i)
 931         zi=c(3,nres+i)
 932           xi=mod(xi,boxxsize)
 933           if (xi.lt.0) xi=xi+boxxsize
 934           yi=mod(yi,boxysize)
 935           if (yi.lt.0) yi=yi+boxysize
 936           zi=mod(zi,boxzsize)
 937           if (zi.lt.0) zi=zi+boxzsize
 938        if ((zi.gt.bordlipbot)
 939      &.and.(zi.lt.bordliptop)) then
 940 C the energy transfer exist
 941         if (zi.lt.buflipbot) then
 942 C what fraction I am in
 943          fracinbuf=1.0d0-
 944      &        ((zi-bordlipbot)/lipbufthick)
 945 C lipbufthick is thickenes of lipid buffore
 946          sslipi=sscalelip(fracinbuf)
 947          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 948         elseif (zi.gt.bufliptop) then
 949          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 950          sslipi=sscalelip(fracinbuf)
 951          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 952         else
 953          sslipi=1.0d0
 954          ssgradlipi=0.0
 955         endif
 956        else
 957          sslipi=0.0d0
 958          ssgradlipi=0.0
 959        endif
 960         dxi=dc_norm(1,nres+i)
 961         dyi=dc_norm(2,nres+i)
 962         dzi=dc_norm(3,nres+i)
 963         dsci_inv=vbld_inv(i+nres)
 964 C
 965 C Calculate SC interaction energy.
 966 C
 967         do iint=1,nint_gr(i)
 968           do j=istart(i,iint),iend(i,iint)
 969             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 970
 971 c              write(iout,*) "PRZED ZWYKLE", evdwij
 972               call dyn_ssbond_ene(i,j,evdwij)
 973 c              write(iout,*) "PO ZWYKLE", evdwij
 974
 975               evdw=evdw+evdwij
 976               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 977      &                        'evdw',i,j,evdwij,' ss'
 978 C triple bond artifac removal
 979              do k=j+1,iend(i,iint)
 980 C search over all next residues
 981               if (dyn_ss_mask(k)) then
 982 C check if they are cysteins
 983 C              write(iout,*) 'k=',k
 984
 985 c              write(iout,*) "PRZED TRI", evdwij
 986                evdwij_przed_tri=evdwij
 987               call triple_ssbond_ene(i,j,k,evdwij)
 988 c               if(evdwij_przed_tri.ne.evdwij) then
 989 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
 990 c               endif
 991
 992 c              write(iout,*) "PO TRI", evdwij
 993 C call the energy function that removes the artifical triple disulfide
 994 C bond the soubroutine is located in ssMD.F
 995               evdw=evdw+evdwij
 996               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 997      &                        'evdw',i,j,evdwij,'tss'
 998               endif!dyn_ss_mask(k)
 999              enddo! k
1000             ELSE
1001             ind=ind+1
1002             itypj=iabs(itype(j))
1003             if (itypj.eq.ntyp1) cycle
1004             dscj_inv=vbld_inv(j+nres)
1005             sig0ij=sigma(itypi,itypj)
1006             chi1=chi(itypi,itypj)
1007             chi2=chi(itypj,itypi)
1008             chi12=chi1*chi2
1009             chip1=chip(itypi)
1010             chip2=chip(itypj)
1011             chip12=chip1*chip2
1012             alf1=alp(itypi)
1013             alf2=alp(itypj)
1014             alf12=0.5D0*(alf1+alf2)
1015 C For diagnostics only!!!
1016 c           chi1=0.0D0
1017 c           chi2=0.0D0
1018 c           chi12=0.0D0
1019 c           chip1=0.0D0
1020 c           chip2=0.0D0
1021 c           chip12=0.0D0
1022 c           alf1=0.0D0
1023 c           alf2=0.0D0
1024 c           alf12=0.0D0
1025             xj=c(1,nres+j)
1026             yj=c(2,nres+j)
1027             zj=c(3,nres+j)
1028           xj=mod(xj,boxxsize)
1029           if (xj.lt.0) xj=xj+boxxsize
1030           yj=mod(yj,boxysize)
1031           if (yj.lt.0) yj=yj+boxysize
1032           zj=mod(zj,boxzsize)
1033           if (zj.lt.0) zj=zj+boxzsize
1034        if ((zj.gt.bordlipbot)
1035      &.and.(zj.lt.bordliptop)) then
1036 C the energy transfer exist
1037         if (zj.lt.buflipbot) then
1038 C what fraction I am in
1039          fracinbuf=1.0d0-
1040      &        ((zj-bordlipbot)/lipbufthick)
1041 C lipbufthick is thickenes of lipid buffore
1042          sslipj=sscalelip(fracinbuf)
1043          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1044         elseif (zj.gt.bufliptop) then
1045          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1046          sslipj=sscalelip(fracinbuf)
1047          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1048         else
1049          sslipj=1.0d0
1050          ssgradlipj=0.0
1051         endif
1052        else
1053          sslipj=0.0d0
1054          ssgradlipj=0.0
1055        endif
1056       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1057      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1058       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1059      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1060 C      write(iout,*) "czy jest 0", bb-bb_lip(itypi,itypj),
1061 C     & bb-bb_aq(itypi,itypj)
1062       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1063       xj_safe=xj
1064       yj_safe=yj
1065       zj_safe=zj
1066       subchap=0
1067       do xshift=-1,1
1068       do yshift=-1,1
1069       do zshift=-1,1
1070           xj=xj_safe+xshift*boxxsize
1071           yj=yj_safe+yshift*boxysize
1072           zj=zj_safe+zshift*boxzsize
1073           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1074           if(dist_temp.lt.dist_init) then
1075             dist_init=dist_temp
1076             xj_temp=xj
1077             yj_temp=yj
1078             zj_temp=zj
1079             subchap=1
1080           endif
1081        enddo
1082        enddo
1083        enddo
1084        if (subchap.eq.1) then
1085           xj=xj_temp-xi
1086           yj=yj_temp-yi
1087           zj=zj_temp-zi
1088        else
1089           xj=xj_safe-xi
1090           yj=yj_safe-yi
1091           zj=zj_safe-zi
1092        endif
1093             dxj=dc_norm(1,nres+j)
1094             dyj=dc_norm(2,nres+j)
1095             dzj=dc_norm(3,nres+j)
1096 c            write (iout,*) i,j,xj,yj,zj
1097             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1098             rij=dsqrt(rrij)
1099             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1100             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1101             if (sss.le.0.0d0) cycle
1102 C Calculate angle-dependent terms of energy and contributions to their
1103 C derivatives.
1104             call sc_angular
1105             sigsq=1.0D0/sigsq
1106             sig=sig0ij*dsqrt(sigsq)
1107             rij_shift=1.0D0/rij-sig+sig0ij
1108 C I hate to put IF's in the loops, but here don't have another choice!!!!
1109             if (rij_shift.le.0.0D0) then
1110               evdw=1.0D20
1111               return
1112             endif
1113             sigder=-sig*sigsq
1114 c---------------------------------------------------------------
1115             rij_shift=1.0D0/rij_shift
1116             fac=rij_shift**expon
1117             e1=fac*fac*aa
1118             e2=fac*bb
1119             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1120             eps2der=evdwij*eps3rt
1121             eps3der=evdwij*eps2rt
1122             evdwij=evdwij*eps2rt*eps3rt
1123             if (bb.gt.0) then
1124               evdw=evdw+evdwij*sss
1125             else
1126               evdw_t=evdw_t+evdwij*sss
1127             endif
1128             ij=icant(itypi,itypj)
1129             aux=eps1*eps2rt**2*eps3rt**2
1130 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1131 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1132 c     &         aux*e2/eps(itypi,itypj)
1133 c            if (lprn) then
1134             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1135             epsi=bb**2/aa
1136 C#define DEBUG
1137 #ifdef DEBUG
1138 C            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1139 C     &        restyp(itypi),i,restyp(itypj),j,
1140 C     &        epsi,sigm,chi1,chi2,chip1,chip2,
1141 C     &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1142 C     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1143 C     &        evdwij
1144              write (iout,*) "pratial sum", evdw,evdw_t,e1,e2,fac,aa
1145 #endif
1146 C#undef DEBUG
1147 c            endif
1148             if (calc_grad) then
1149 C Calculate gradient components.
1150             e1=e1*eps1*eps2rt**2*eps3rt**2
1151             fac=-expon*(e1+evdwij)*rij_shift
1152             sigder=fac*sigder
1153             fac=rij*fac
1154             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1155             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1156      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1157      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1158      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1159             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1160             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1161 C Calculate the radial part of the gradient
1162             gg(1)=xj*fac
1163             gg(2)=yj*fac
1164             gg(3)=zj*fac
1165 C Calculate angular part of the gradient.
1166             call sc_grad
1167             endif
1168             ENDIF    ! dyn_ss
1169           enddo      ! j
1170         enddo        ! iint
1171       enddo          ! i
1172       return
1173       end
1174 C-----------------------------------------------------------------------------
1175       subroutine egbv(evdw,evdw_t)
1176 C
1177 C This subroutine calculates the interaction energy of nonbonded side chains
1178 C assuming the Gay-Berne-Vorobjev potential of interaction.
1179 C
1180       implicit real*8 (a-h,o-z)
1181       include 'DIMENSIONS'
1182       include 'sizesclu.dat'
1183       include "DIMENSIONS.COMPAR"
1184       include 'COMMON.GEO'
1185       include 'COMMON.VAR'
1186       include 'COMMON.LOCAL'
1187       include 'COMMON.CHAIN'
1188       include 'COMMON.DERIV'
1189       include 'COMMON.NAMES'
1190       include 'COMMON.INTERACT'
1191       include 'COMMON.IOUNITS'
1192       include 'COMMON.CALC'
1193       common /srutu/ icall
1194       logical lprn
1195       integer icant
1196       external icant
1197       integer xshift,yshift,zshift
1198       evdw=0.0D0
1199       evdw_t=0.0d0
1200 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1201       evdw=0.0D0
1202       lprn=.false.
1203 c      if (icall.gt.0) lprn=.true.
1204       ind=0
1205       do i=iatsc_s,iatsc_e
1206         itypi=iabs(itype(i))
1207         if (itypi.eq.ntyp1) cycle
1208         itypi1=iabs(itype(i+1))
1209         xi=c(1,nres+i)
1210         yi=c(2,nres+i)
1211         zi=c(3,nres+i)
1212         dxi=dc_norm(1,nres+i)
1213         dyi=dc_norm(2,nres+i)
1214         dzi=dc_norm(3,nres+i)
1215         dsci_inv=vbld_inv(i+nres)
1216 C returning the ith atom to box
1217           xi=mod(xi,boxxsize)
1218           if (xi.lt.0) xi=xi+boxxsize
1219           yi=mod(yi,boxysize)
1220           if (yi.lt.0) yi=yi+boxysize
1221           zi=mod(zi,boxzsize)
1222           if (zi.lt.0) zi=zi+boxzsize
1223        if ((zi.gt.bordlipbot)
1224      &.and.(zi.lt.bordliptop)) then
1225 C the energy transfer exist
1226         if (zi.lt.buflipbot) then
1227 C what fraction I am in
1228          fracinbuf=1.0d0-
1229      &        ((zi-bordlipbot)/lipbufthick)
1230 C lipbufthick is thickenes of lipid buffore
1231          sslipi=sscalelip(fracinbuf)
1232          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1233         elseif (zi.gt.bufliptop) then
1234          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1235          sslipi=sscalelip(fracinbuf)
1236          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1237         else
1238          sslipi=1.0d0
1239          ssgradlipi=0.0
1240         endif
1241        else
1242          sslipi=0.0d0
1243          ssgradlipi=0.0
1244        endif
1245 C
1246 C Calculate SC interaction energy.
1247 C
1248         do iint=1,nint_gr(i)
1249           do j=istart(i,iint),iend(i,iint)
1250             ind=ind+1
1251             itypj=iabs(itype(j))
1252             if (itypj.eq.ntyp1) cycle
1253             dscj_inv=vbld_inv(j+nres)
1254             sig0ij=sigma(itypi,itypj)
1255             r0ij=r0(itypi,itypj)
1256             chi1=chi(itypi,itypj)
1257             chi2=chi(itypj,itypi)
1258             chi12=chi1*chi2
1259             chip1=chip(itypi)
1260             chip2=chip(itypj)
1261             chip12=chip1*chip2
1262             alf1=alp(itypi)
1263             alf2=alp(itypj)
1264             alf12=0.5D0*(alf1+alf2)
1265 C For diagnostics only!!!
1266 c           chi1=0.0D0
1267 c           chi2=0.0D0
1268 c           chi12=0.0D0
1269 c           chip1=0.0D0
1270 c           chip2=0.0D0
1271 c           chip12=0.0D0
1272 c           alf1=0.0D0
1273 c           alf2=0.0D0
1274 c           alf12=0.0D0
1275             xj=c(1,nres+j)
1276             yj=c(2,nres+j)
1277             zj=c(3,nres+j)
1278 C returning jth atom to box
1279           xj=mod(xj,boxxsize)
1280           if (xj.lt.0) xj=xj+boxxsize
1281           yj=mod(yj,boxysize)
1282           if (yj.lt.0) yj=yj+boxysize
1283           zj=mod(zj,boxzsize)
1284           if (zj.lt.0) zj=zj+boxzsize
1285        if ((zj.gt.bordlipbot)
1286      &.and.(zj.lt.bordliptop)) then
1287 C the energy transfer exist
1288         if (zj.lt.buflipbot) then
1289 C what fraction I am in
1290          fracinbuf=1.0d0-
1291      &        ((zj-bordlipbot)/lipbufthick)
1292 C lipbufthick is thickenes of lipid buffore
1293          sslipj=sscalelip(fracinbuf)
1294          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1295         elseif (zj.gt.bufliptop) then
1296          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1297          sslipj=sscalelip(fracinbuf)
1298          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1299         else
1300          sslipj=1.0d0
1301          ssgradlipj=0.0
1302         endif
1303        else
1304          sslipj=0.0d0
1305          ssgradlipj=0.0
1306        endif
1307       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1308      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1309       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1310      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1311 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1312 C checking the distance
1313       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1314       xj_safe=xj
1315       yj_safe=yj
1316       zj_safe=zj
1317       subchap=0
1318 C finding the closest
1319       do xshift=-1,1
1320       do yshift=-1,1
1321       do zshift=-1,1
1322           xj=xj_safe+xshift*boxxsize
1323           yj=yj_safe+yshift*boxysize
1324           zj=zj_safe+zshift*boxzsize
1325           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1326           if(dist_temp.lt.dist_init) then
1327             dist_init=dist_temp
1328             xj_temp=xj
1329             yj_temp=yj
1330             zj_temp=zj
1331             subchap=1
1332           endif
1333        enddo
1334        enddo
1335        enddo
1336        if (subchap.eq.1) then
1337           xj=xj_temp-xi
1338           yj=yj_temp-yi
1339           zj=zj_temp-zi
1340        else
1341           xj=xj_safe-xi
1342           yj=yj_safe-yi
1343           zj=zj_safe-zi
1344        endif
1345             dxj=dc_norm(1,nres+j)
1346             dyj=dc_norm(2,nres+j)
1347             dzj=dc_norm(3,nres+j)
1348             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1349             rij=dsqrt(rrij)
1350 C Calculate angle-dependent terms of energy and contributions to their
1351 C derivatives.
1352             call sc_angular
1353             sigsq=1.0D0/sigsq
1354             sig=sig0ij*dsqrt(sigsq)
1355             rij_shift=1.0D0/rij-sig+r0ij
1356 C I hate to put IF's in the loops, but here don't have another choice!!!!
1357             if (rij_shift.le.0.0D0) then
1358               evdw=1.0D20
1359               return
1360             endif
1361             sigder=-sig*sigsq
1362 c---------------------------------------------------------------
1363             rij_shift=1.0D0/rij_shift
1364             fac=rij_shift**expon
1365             e1=fac*fac*aa
1366             e2=fac*bb
1367             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1368             eps2der=evdwij*eps3rt
1369             eps3der=evdwij*eps2rt
1370             fac_augm=rrij**expon
1371             e_augm=augm(itypi,itypj)*fac_augm
1372             evdwij=evdwij*eps2rt*eps3rt
1373             if (bb.gt.0.0d0) then
1374               evdw=evdw+evdwij+e_augm
1375             else
1376               evdw_t=evdw_t+evdwij+e_augm
1377             endif
1378             ij=icant(itypi,itypj)
1379             aux=eps1*eps2rt**2*eps3rt**2
1380 c            if (lprn) then
1381 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1382 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1383 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1384 c     &        restyp(itypi),i,restyp(itypj),j,
1385 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1386 c     &        chi1,chi2,chip1,chip2,
1387 c     &        eps1,eps2rt**2,eps3rt**2,
1388 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1389 c     &        evdwij+e_augm
1390 c            endif
1391             if (calc_grad) then
1392 C Calculate gradient components.
1393             e1=e1*eps1*eps2rt**2*eps3rt**2
1394             fac=-expon*(e1+evdwij)*rij_shift
1395             sigder=fac*sigder
1396             fac=rij*fac-2*expon*rrij*e_augm
1397 C Calculate the radial part of the gradient
1398             gg(1)=xj*fac
1399             gg(2)=yj*fac
1400             gg(3)=zj*fac
1401 C Calculate angular part of the gradient.
1402             call sc_grad
1403             endif
1404           enddo      ! j
1405         enddo        ! iint
1406       enddo          ! i
1407       return
1408       end
1409 C-----------------------------------------------------------------------------
1410       subroutine sc_angular
1411 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1412 C om12. Called by ebp, egb, and egbv.
1413       implicit none
1414       include 'COMMON.CALC'
1415       erij(1)=xj*rij
1416       erij(2)=yj*rij
1417       erij(3)=zj*rij
1418       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1419       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1420       om12=dxi*dxj+dyi*dyj+dzi*dzj
1421       chiom12=chi12*om12
1422 C Calculate eps1(om12) and its derivative in om12
1423       faceps1=1.0D0-om12*chiom12
1424       faceps1_inv=1.0D0/faceps1
1425       eps1=dsqrt(faceps1_inv)
1426 C Following variable is eps1*deps1/dom12
1427       eps1_om12=faceps1_inv*chiom12
1428 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1429 C and om12.
1430       om1om2=om1*om2
1431       chiom1=chi1*om1
1432       chiom2=chi2*om2
1433       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1434       sigsq=1.0D0-facsig*faceps1_inv
1435       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1436       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1437       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1438 C Calculate eps2 and its derivatives in om1, om2, and om12.
1439       chipom1=chip1*om1
1440       chipom2=chip2*om2
1441       chipom12=chip12*om12
1442       facp=1.0D0-om12*chipom12
1443       facp_inv=1.0D0/facp
1444       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1445 C Following variable is the square root of eps2
1446       eps2rt=1.0D0-facp1*facp_inv
1447 C Following three variables are the derivatives of the square root of eps
1448 C in om1, om2, and om12.
1449       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1450       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1451       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1452 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1453       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1454 C Calculate whole angle-dependent part of epsilon and contributions
1455 C to its derivatives
1456       return
1457       end
1458 C----------------------------------------------------------------------------
1459       subroutine sc_grad
1460       implicit real*8 (a-h,o-z)
1461       include 'DIMENSIONS'
1462       include 'sizesclu.dat'
1463       include 'COMMON.CHAIN'
1464       include 'COMMON.DERIV'
1465       include 'COMMON.CALC'
1466       double precision dcosom1(3),dcosom2(3)
1467       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1468       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1469       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1470      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1471       do k=1,3
1472         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1473         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1474       enddo
1475       do k=1,3
1476         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1477       enddo
1478       do k=1,3
1479         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1480      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1481      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1482         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipi(k)
1483      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1484      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1485       enddo
1486 C
1487 C Calculate the components of the gradient in DC and X
1488 C
1489       do k=i,j-1
1490         do l=1,3
1491           gvdwc(l,k)=gvdwc(l,k)+gg(l)+gg_lipi(l)
1492         enddo
1493       enddo
1494       do l=1,3
1495          gvdwc(l,j)=gvdwc(l,j)+gg_lipj(l)
1496       enddo
1497       return
1498       end
1499 c------------------------------------------------------------------------------
1500       subroutine vec_and_deriv
1501       implicit real*8 (a-h,o-z)
1502       include 'DIMENSIONS'
1503       include 'sizesclu.dat'
1504       include 'COMMON.IOUNITS'
1505       include 'COMMON.GEO'
1506       include 'COMMON.VAR'
1507       include 'COMMON.LOCAL'
1508       include 'COMMON.CHAIN'
1509       include 'COMMON.VECTORS'
1510       include 'COMMON.DERIV'
1511       include 'COMMON.INTERACT'
1512       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1513 C Compute the local reference systems. For reference system (i), the
1514 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1515 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1516       do i=1,nres-1
1517 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1518           if (i.eq.nres-1) then
1519 C Case of the last full residue
1520 C Compute the Z-axis
1521             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1522             costh=dcos(pi-theta(nres))
1523             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1524             do k=1,3
1525               uz(k,i)=fac*uz(k,i)
1526             enddo
1527             if (calc_grad) then
1528 C Compute the derivatives of uz
1529             uzder(1,1,1)= 0.0d0
1530             uzder(2,1,1)=-dc_norm(3,i-1)
1531             uzder(3,1,1)= dc_norm(2,i-1)
1532             uzder(1,2,1)= dc_norm(3,i-1)
1533             uzder(2,2,1)= 0.0d0
1534             uzder(3,2,1)=-dc_norm(1,i-1)
1535             uzder(1,3,1)=-dc_norm(2,i-1)
1536             uzder(2,3,1)= dc_norm(1,i-1)
1537             uzder(3,3,1)= 0.0d0
1538             uzder(1,1,2)= 0.0d0
1539             uzder(2,1,2)= dc_norm(3,i)
1540             uzder(3,1,2)=-dc_norm(2,i)
1541             uzder(1,2,2)=-dc_norm(3,i)
1542             uzder(2,2,2)= 0.0d0
1543             uzder(3,2,2)= dc_norm(1,i)
1544             uzder(1,3,2)= dc_norm(2,i)
1545             uzder(2,3,2)=-dc_norm(1,i)
1546             uzder(3,3,2)= 0.0d0
1547             endif
1548 C Compute the Y-axis
1549             facy=fac
1550             do k=1,3
1551               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1552             enddo
1553             if (calc_grad) then
1554 C Compute the derivatives of uy
1555             do j=1,3
1556               do k=1,3
1557                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1558      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1559                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1560               enddo
1561               uyder(j,j,1)=uyder(j,j,1)-costh
1562               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1563             enddo
1564             do j=1,2
1565               do k=1,3
1566                 do l=1,3
1567                   uygrad(l,k,j,i)=uyder(l,k,j)
1568                   uzgrad(l,k,j,i)=uzder(l,k,j)
1569                 enddo
1570               enddo
1571             enddo
1572             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1573             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1574             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1575             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1576             endif
1577           else
1578 C Other residues
1579 C Compute the Z-axis
1580             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1581             costh=dcos(pi-theta(i+2))
1582             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1583             do k=1,3
1584               uz(k,i)=fac*uz(k,i)
1585             enddo
1586             if (calc_grad) then
1587 C Compute the derivatives of uz
1588             uzder(1,1,1)= 0.0d0
1589             uzder(2,1,1)=-dc_norm(3,i+1)
1590             uzder(3,1,1)= dc_norm(2,i+1)
1591             uzder(1,2,1)= dc_norm(3,i+1)
1592             uzder(2,2,1)= 0.0d0
1593             uzder(3,2,1)=-dc_norm(1,i+1)
1594             uzder(1,3,1)=-dc_norm(2,i+1)
1595             uzder(2,3,1)= dc_norm(1,i+1)
1596             uzder(3,3,1)= 0.0d0
1597             uzder(1,1,2)= 0.0d0
1598             uzder(2,1,2)= dc_norm(3,i)
1599             uzder(3,1,2)=-dc_norm(2,i)
1600             uzder(1,2,2)=-dc_norm(3,i)
1601             uzder(2,2,2)= 0.0d0
1602             uzder(3,2,2)= dc_norm(1,i)
1603             uzder(1,3,2)= dc_norm(2,i)
1604             uzder(2,3,2)=-dc_norm(1,i)
1605             uzder(3,3,2)= 0.0d0
1606             endif
1607 C Compute the Y-axis
1608             facy=fac
1609             do k=1,3
1610               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1611             enddo
1612             if (calc_grad) then
1613 C Compute the derivatives of uy
1614             do j=1,3
1615               do k=1,3
1616                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1617      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1618                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1619               enddo
1620               uyder(j,j,1)=uyder(j,j,1)-costh
1621               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1622             enddo
1623             do j=1,2
1624               do k=1,3
1625                 do l=1,3
1626                   uygrad(l,k,j,i)=uyder(l,k,j)
1627                   uzgrad(l,k,j,i)=uzder(l,k,j)
1628                 enddo
1629               enddo
1630             enddo
1631             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1632             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1633             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1634             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1635           endif
1636           endif
1637       enddo
1638       if (calc_grad) then
1639       do i=1,nres-1
1640         vbld_inv_temp(1)=vbld_inv(i+1)
1641         if (i.lt.nres-1) then
1642           vbld_inv_temp(2)=vbld_inv(i+2)
1643         else
1644           vbld_inv_temp(2)=vbld_inv(i)
1645         endif
1646         do j=1,2
1647           do k=1,3
1648             do l=1,3
1649               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1650               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1651             enddo
1652           enddo
1653         enddo
1654       enddo
1655       endif
1656       return
1657       end
1658 C-----------------------------------------------------------------------------
1659       subroutine vec_and_deriv_test
1660       implicit real*8 (a-h,o-z)
1661       include 'DIMENSIONS'
1662       include 'sizesclu.dat'
1663       include 'COMMON.IOUNITS'
1664       include 'COMMON.GEO'
1665       include 'COMMON.VAR'
1666       include 'COMMON.LOCAL'
1667       include 'COMMON.CHAIN'
1668       include 'COMMON.VECTORS'
1669       dimension uyder(3,3,2),uzder(3,3,2)
1670 C Compute the local reference systems. For reference system (i), the
1671 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1672 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1673       do i=1,nres-1
1674           if (i.eq.nres-1) then
1675 C Case of the last full residue
1676 C Compute the Z-axis
1677             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1678             costh=dcos(pi-theta(nres))
1679             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1680 c            write (iout,*) 'fac',fac,
1681 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1682             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1683             do k=1,3
1684               uz(k,i)=fac*uz(k,i)
1685             enddo
1686 C Compute the derivatives of uz
1687             uzder(1,1,1)= 0.0d0
1688             uzder(2,1,1)=-dc_norm(3,i-1)
1689             uzder(3,1,1)= dc_norm(2,i-1)
1690             uzder(1,2,1)= dc_norm(3,i-1)
1691             uzder(2,2,1)= 0.0d0
1692             uzder(3,2,1)=-dc_norm(1,i-1)
1693             uzder(1,3,1)=-dc_norm(2,i-1)
1694             uzder(2,3,1)= dc_norm(1,i-1)
1695             uzder(3,3,1)= 0.0d0
1696             uzder(1,1,2)= 0.0d0
1697             uzder(2,1,2)= dc_norm(3,i)
1698             uzder(3,1,2)=-dc_norm(2,i)
1699             uzder(1,2,2)=-dc_norm(3,i)
1700             uzder(2,2,2)= 0.0d0
1701             uzder(3,2,2)= dc_norm(1,i)
1702             uzder(1,3,2)= dc_norm(2,i)
1703             uzder(2,3,2)=-dc_norm(1,i)
1704             uzder(3,3,2)= 0.0d0
1705 C Compute the Y-axis
1706             do k=1,3
1707               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1708             enddo
1709             facy=fac
1710             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1711      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1712      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1713             do k=1,3
1714 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1715               uy(k,i)=
1716 c     &        facy*(
1717      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1718      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1719 c     &        )
1720             enddo
1721 c            write (iout,*) 'facy',facy,
1722 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1723             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1724             do k=1,3
1725               uy(k,i)=facy*uy(k,i)
1726             enddo
1727 C Compute the derivatives of uy
1728             do j=1,3
1729               do k=1,3
1730                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1731      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1732                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1733               enddo
1734 c              uyder(j,j,1)=uyder(j,j,1)-costh
1735 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1736               uyder(j,j,1)=uyder(j,j,1)
1737      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1738               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1739      &          +uyder(j,j,2)
1740             enddo
1741             do j=1,2
1742               do k=1,3
1743                 do l=1,3
1744                   uygrad(l,k,j,i)=uyder(l,k,j)
1745                   uzgrad(l,k,j,i)=uzder(l,k,j)
1746                 enddo
1747               enddo
1748             enddo
1749             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1750             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1751             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1752             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1753           else
1754 C Other residues
1755 C Compute the Z-axis
1756             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1757             costh=dcos(pi-theta(i+2))
1758             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1759             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1760             do k=1,3
1761               uz(k,i)=fac*uz(k,i)
1762             enddo
1763 C Compute the derivatives of uz
1764             uzder(1,1,1)= 0.0d0
1765             uzder(2,1,1)=-dc_norm(3,i+1)
1766             uzder(3,1,1)= dc_norm(2,i+1)
1767             uzder(1,2,1)= dc_norm(3,i+1)
1768             uzder(2,2,1)= 0.0d0
1769             uzder(3,2,1)=-dc_norm(1,i+1)
1770             uzder(1,3,1)=-dc_norm(2,i+1)
1771             uzder(2,3,1)= dc_norm(1,i+1)
1772             uzder(3,3,1)= 0.0d0
1773             uzder(1,1,2)= 0.0d0
1774             uzder(2,1,2)= dc_norm(3,i)
1775             uzder(3,1,2)=-dc_norm(2,i)
1776             uzder(1,2,2)=-dc_norm(3,i)
1777             uzder(2,2,2)= 0.0d0
1778             uzder(3,2,2)= dc_norm(1,i)
1779             uzder(1,3,2)= dc_norm(2,i)
1780             uzder(2,3,2)=-dc_norm(1,i)
1781             uzder(3,3,2)= 0.0d0
1782 C Compute the Y-axis
1783             facy=fac
1784             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1785      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1786      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1787             do k=1,3
1788 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1789               uy(k,i)=
1790 c     &        facy*(
1791      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1792      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1793 c     &        )
1794             enddo
1795 c            write (iout,*) 'facy',facy,
1796 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1797             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1798             do k=1,3
1799               uy(k,i)=facy*uy(k,i)
1800             enddo
1801 C Compute the derivatives of uy
1802             do j=1,3
1803               do k=1,3
1804                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1805      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1806                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1807               enddo
1808 c              uyder(j,j,1)=uyder(j,j,1)-costh
1809 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1810               uyder(j,j,1)=uyder(j,j,1)
1811      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1812               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1813      &          +uyder(j,j,2)
1814             enddo
1815             do j=1,2
1816               do k=1,3
1817                 do l=1,3
1818                   uygrad(l,k,j,i)=uyder(l,k,j)
1819                   uzgrad(l,k,j,i)=uzder(l,k,j)
1820                 enddo
1821               enddo
1822             enddo
1823             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1824             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1825             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1826             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1827           endif
1828       enddo
1829       do i=1,nres-1
1830         do j=1,2
1831           do k=1,3
1832             do l=1,3
1833               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1834               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1835             enddo
1836           enddo
1837         enddo
1838       enddo
1839       return
1840       end
1841 C-----------------------------------------------------------------------------
1842       subroutine check_vecgrad
1843       implicit real*8 (a-h,o-z)
1844       include 'DIMENSIONS'
1845       include 'sizesclu.dat'
1846       include 'COMMON.IOUNITS'
1847       include 'COMMON.GEO'
1848       include 'COMMON.VAR'
1849       include 'COMMON.LOCAL'
1850       include 'COMMON.CHAIN'
1851       include 'COMMON.VECTORS'
1852       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1853       dimension uyt(3,maxres),uzt(3,maxres)
1854       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1855       double precision delta /1.0d-7/
1856       call vec_and_deriv
1857 cd      do i=1,nres
1858 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1859 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1860 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1861 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1862 cd     &     (dc_norm(if90,i),if90=1,3)
1863 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1864 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1865 cd          write(iout,'(a)')
1866 cd      enddo
1867       do i=1,nres
1868         do j=1,2
1869           do k=1,3
1870             do l=1,3
1871               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1872               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1873             enddo
1874           enddo
1875         enddo
1876       enddo
1877       call vec_and_deriv
1878       do i=1,nres
1879         do j=1,3
1880           uyt(j,i)=uy(j,i)
1881           uzt(j,i)=uz(j,i)
1882         enddo
1883       enddo
1884       do i=1,nres
1885 cd        write (iout,*) 'i=',i
1886         do k=1,3
1887           erij(k)=dc_norm(k,i)
1888         enddo
1889         do j=1,3
1890           do k=1,3
1891             dc_norm(k,i)=erij(k)
1892           enddo
1893           dc_norm(j,i)=dc_norm(j,i)+delta
1894 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1895 c          do k=1,3
1896 c            dc_norm(k,i)=dc_norm(k,i)/fac
1897 c          enddo
1898 c          write (iout,*) (dc_norm(k,i),k=1,3)
1899 c          write (iout,*) (erij(k),k=1,3)
1900           call vec_and_deriv
1901           do k=1,3
1902             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1903             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1904             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1905             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1906           enddo
1907 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1908 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1909 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1910         enddo
1911         do k=1,3
1912           dc_norm(k,i)=erij(k)
1913         enddo
1914 cd        do k=1,3
1915 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1916 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1917 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1918 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1919 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1920 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1921 cd          write (iout,'(a)')
1922 cd        enddo
1923       enddo
1924       return
1925       end
1926 C--------------------------------------------------------------------------
1927       subroutine set_matrices
1928       implicit real*8 (a-h,o-z)
1929       include 'DIMENSIONS'
1930       include 'sizesclu.dat'
1931       include 'COMMON.IOUNITS'
1932       include 'COMMON.GEO'
1933       include 'COMMON.VAR'
1934       include 'COMMON.LOCAL'
1935       include 'COMMON.CHAIN'
1936       include 'COMMON.DERIV'
1937       include 'COMMON.INTERACT'
1938       include 'COMMON.CONTACTS'
1939       include 'COMMON.TORSION'
1940       include 'COMMON.VECTORS'
1941       include 'COMMON.FFIELD'
1942       double precision auxvec(2),auxmat(2,2)
1943 C
1944 C Compute the virtual-bond-torsional-angle dependent quantities needed
1945 C to calculate the el-loc multibody terms of various order.
1946 C
1947       do i=3,nres+1
1948         if (i .lt. nres+1) then
1949           sin1=dsin(phi(i))
1950           cos1=dcos(phi(i))
1951           sintab(i-2)=sin1
1952           costab(i-2)=cos1
1953           obrot(1,i-2)=cos1
1954           obrot(2,i-2)=sin1
1955           sin2=dsin(2*phi(i))
1956           cos2=dcos(2*phi(i))
1957           sintab2(i-2)=sin2
1958           costab2(i-2)=cos2
1959           obrot2(1,i-2)=cos2
1960           obrot2(2,i-2)=sin2
1961           Ug(1,1,i-2)=-cos1
1962           Ug(1,2,i-2)=-sin1
1963           Ug(2,1,i-2)=-sin1
1964           Ug(2,2,i-2)= cos1
1965           Ug2(1,1,i-2)=-cos2
1966           Ug2(1,2,i-2)=-sin2
1967           Ug2(2,1,i-2)=-sin2
1968           Ug2(2,2,i-2)= cos2
1969         else
1970           costab(i-2)=1.0d0
1971           sintab(i-2)=0.0d0
1972           obrot(1,i-2)=1.0d0
1973           obrot(2,i-2)=0.0d0
1974           obrot2(1,i-2)=0.0d0
1975           obrot2(2,i-2)=0.0d0
1976           Ug(1,1,i-2)=1.0d0
1977           Ug(1,2,i-2)=0.0d0
1978           Ug(2,1,i-2)=0.0d0
1979           Ug(2,2,i-2)=1.0d0
1980           Ug2(1,1,i-2)=0.0d0
1981           Ug2(1,2,i-2)=0.0d0
1982           Ug2(2,1,i-2)=0.0d0
1983           Ug2(2,2,i-2)=0.0d0
1984         endif
1985         if (i .gt. 3 .and. i .lt. nres+1) then
1986           obrot_der(1,i-2)=-sin1
1987           obrot_der(2,i-2)= cos1
1988           Ugder(1,1,i-2)= sin1
1989           Ugder(1,2,i-2)=-cos1
1990           Ugder(2,1,i-2)=-cos1
1991           Ugder(2,2,i-2)=-sin1
1992           dwacos2=cos2+cos2
1993           dwasin2=sin2+sin2
1994           obrot2_der(1,i-2)=-dwasin2
1995           obrot2_der(2,i-2)= dwacos2
1996           Ug2der(1,1,i-2)= dwasin2
1997           Ug2der(1,2,i-2)=-dwacos2
1998           Ug2der(2,1,i-2)=-dwacos2
1999           Ug2der(2,2,i-2)=-dwasin2
2000         else
2001           obrot_der(1,i-2)=0.0d0
2002           obrot_der(2,i-2)=0.0d0
2003           Ugder(1,1,i-2)=0.0d0
2004           Ugder(1,2,i-2)=0.0d0
2005           Ugder(2,1,i-2)=0.0d0
2006           Ugder(2,2,i-2)=0.0d0
2007           obrot2_der(1,i-2)=0.0d0
2008           obrot2_der(2,i-2)=0.0d0
2009           Ug2der(1,1,i-2)=0.0d0
2010           Ug2der(1,2,i-2)=0.0d0
2011           Ug2der(2,1,i-2)=0.0d0
2012           Ug2der(2,2,i-2)=0.0d0
2013         endif
2014         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2015           if (itype(i-2).le.ntyp) then
2016             iti = itortyp(itype(i-2))
2017           else
2018             iti=ntortyp+1
2019           endif
2020         else
2021           iti=ntortyp+1
2022         endif
2023         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2024           if (itype(i-1).le.ntyp) then
2025             iti1 = itortyp(itype(i-1))
2026           else
2027             iti1=ntortyp+1
2028           endif
2029         else
2030           iti1=ntortyp+1
2031         endif
2032 cd        write (iout,*) '*******i',i,' iti1',iti
2033 cd        write (iout,*) 'b1',b1(:,iti)
2034 cd        write (iout,*) 'b2',b2(:,iti)
2035 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2036 c        print *,"itilde1 i iti iti1",i,iti,iti1
2037         if (i .gt. iatel_s+2) then
2038           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2039           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2040           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2041           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2042           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2043           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2044           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2045         else
2046           do k=1,2
2047             Ub2(k,i-2)=0.0d0
2048             Ctobr(k,i-2)=0.0d0
2049             Dtobr2(k,i-2)=0.0d0
2050             do l=1,2
2051               EUg(l,k,i-2)=0.0d0
2052               CUg(l,k,i-2)=0.0d0
2053               DUg(l,k,i-2)=0.0d0
2054               DtUg2(l,k,i-2)=0.0d0
2055             enddo
2056           enddo
2057         endif
2058 c        print *,"itilde2 i iti iti1",i,iti,iti1
2059         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2060         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2061         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2062         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2063         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2064         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2065         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2066 c        print *,"itilde3 i iti iti1",i,iti,iti1
2067         do k=1,2
2068           muder(k,i-2)=Ub2der(k,i-2)
2069         enddo
2070         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2071           if (itype(i-1).le.ntyp) then
2072             iti1 = itortyp(itype(i-1))
2073           else
2074             iti1=ntortyp+1
2075           endif
2076         else
2077           iti1=ntortyp+1
2078         endif
2079         do k=1,2
2080           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2081         enddo
2082 C Vectors and matrices dependent on a single virtual-bond dihedral.
2083         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2084         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2085         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2086         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2087         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2088         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2089         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2090         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2091         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2092 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2093 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2094       enddo
2095 C Matrices dependent on two consecutive virtual-bond dihedrals.
2096 C The order of matrices is from left to right.
2097       do i=2,nres-1
2098         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2099         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2100         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2101         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2102         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2103         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2104         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2105         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2106       enddo
2107 cd      do i=1,nres
2108 cd        iti = itortyp(itype(i))
2109 cd        write (iout,*) i
2110 cd        do j=1,2
2111 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2112 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2113 cd        enddo
2114 cd      enddo
2115       return
2116       end
2117 C--------------------------------------------------------------------------
2118       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2119 C
2120 C This subroutine calculates the average interaction energy and its gradient
2121 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2122 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2123 C The potential depends both on the distance of peptide-group centers and on
2124 C the orientation of the CA-CA virtual bonds.
2125 C
2126       implicit real*8 (a-h,o-z)
2127       include 'DIMENSIONS'
2128       include 'sizesclu.dat'
2129       include 'COMMON.CONTROL'
2130       include 'COMMON.IOUNITS'
2131       include 'COMMON.GEO'
2132       include 'COMMON.VAR'
2133       include 'COMMON.LOCAL'
2134       include 'COMMON.CHAIN'
2135       include 'COMMON.DERIV'
2136       include 'COMMON.INTERACT'
2137       include 'COMMON.CONTACTS'
2138       include 'COMMON.TORSION'
2139       include 'COMMON.VECTORS'
2140       include 'COMMON.FFIELD'
2141       include 'COMMON.SHIELD'
2142
2143       integer xshift,yshift,zshift
2144       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2145      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2146       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2147      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2148       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2149 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2150       double precision scal_el /0.5d0/
2151 C 12/13/98
2152 C 13-go grudnia roku pamietnego...
2153       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2154      &                   0.0d0,1.0d0,0.0d0,
2155      &                   0.0d0,0.0d0,1.0d0/
2156 cd      write(iout,*) 'In EELEC'
2157 cd      do i=1,nloctyp
2158 cd        write(iout,*) 'Type',i
2159 cd        write(iout,*) 'B1',B1(:,i)
2160 cd        write(iout,*) 'B2',B2(:,i)
2161 cd        write(iout,*) 'CC',CC(:,:,i)
2162 cd        write(iout,*) 'DD',DD(:,:,i)
2163 cd        write(iout,*) 'EE',EE(:,:,i)
2164 cd      enddo
2165 cd      call check_vecgrad
2166 cd      stop
2167       if (icheckgrad.eq.1) then
2168         do i=1,nres-1
2169           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2170           do k=1,3
2171             dc_norm(k,i)=dc(k,i)*fac
2172           enddo
2173 c          write (iout,*) 'i',i,' fac',fac
2174         enddo
2175       endif
2176       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2177      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2178      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2179 cd      if (wel_loc.gt.0.0d0) then
2180         if (icheckgrad.eq.1) then
2181         call vec_and_deriv_test
2182         else
2183         call vec_and_deriv
2184         endif
2185         call set_matrices
2186       endif
2187 cd      do i=1,nres-1
2188 cd        write (iout,*) 'i=',i
2189 cd        do k=1,3
2190 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2191 cd        enddo
2192 cd        do k=1,3
2193 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2194 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2195 cd        enddo
2196 cd      enddo
2197       num_conti_hb=0
2198       ees=0.0D0
2199       evdw1=0.0D0
2200       eel_loc=0.0d0
2201       eello_turn3=0.0d0
2202       eello_turn4=0.0d0
2203       ind=0
2204       do i=1,nres
2205         num_cont_hb(i)=0
2206       enddo
2207 cd      print '(a)','Enter EELEC'
2208 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2209       do i=1,nres
2210         gel_loc_loc(i)=0.0d0
2211         gcorr_loc(i)=0.0d0
2212       enddo
2213       do i=iatel_s,iatel_e
2214 cAna           if (i.le.1) cycle
2215            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2216 cAna     &  .or. ((i+2).gt.nres)
2217 cAna     &  .or. ((i-1).le.0)
2218 cAna     &  .or. itype(i+2).eq.ntyp1
2219 cAna     &  .or. itype(i-1).eq.ntyp1
2220      &) cycle
2221 C         endif
2222         if (itel(i).eq.0) goto 1215
2223         dxi=dc(1,i)
2224         dyi=dc(2,i)
2225         dzi=dc(3,i)
2226         dx_normi=dc_norm(1,i)
2227         dy_normi=dc_norm(2,i)
2228         dz_normi=dc_norm(3,i)
2229         xmedi=c(1,i)+0.5d0*dxi
2230         ymedi=c(2,i)+0.5d0*dyi
2231         zmedi=c(3,i)+0.5d0*dzi
2232           xmedi=mod(xmedi,boxxsize)
2233           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2234           ymedi=mod(ymedi,boxysize)
2235           if (ymedi.lt.0) ymedi=ymedi+boxysize
2236           zmedi=mod(zmedi,boxzsize)
2237           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2238         num_conti=0
2239 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2240         do j=ielstart(i),ielend(i)
2241 cAna          if (j.le.1) cycle
2242           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2243 cAna     & .or.((j+2).gt.nres)
2244 cAna     & .or.((j-1).le.0)
2245 cAna     & .or.itype(j+2).eq.ntyp1
2246 cAna     & .or.itype(j-1).eq.ntyp1
2247      &) cycle
2248 C         endif
2249           if (itel(j).eq.0) goto 1216
2250           ind=ind+1
2251           iteli=itel(i)
2252           itelj=itel(j)
2253           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2254           aaa=app(iteli,itelj)
2255           bbb=bpp(iteli,itelj)
2256 C Diagnostics only!!!
2257 c         aaa=0.0D0
2258 c         bbb=0.0D0
2259 c         ael6i=0.0D0
2260 c         ael3i=0.0D0
2261 C End diagnostics
2262           ael6i=ael6(iteli,itelj)
2263           ael3i=ael3(iteli,itelj)
2264           dxj=dc(1,j)
2265           dyj=dc(2,j)
2266           dzj=dc(3,j)
2267           dx_normj=dc_norm(1,j)
2268           dy_normj=dc_norm(2,j)
2269           dz_normj=dc_norm(3,j)
2270           xj=c(1,j)+0.5D0*dxj
2271           yj=c(2,j)+0.5D0*dyj
2272           zj=c(3,j)+0.5D0*dzj
2273          xj=mod(xj,boxxsize)
2274           if (xj.lt.0) xj=xj+boxxsize
2275           yj=mod(yj,boxysize)
2276           if (yj.lt.0) yj=yj+boxysize
2277           zj=mod(zj,boxzsize)
2278           if (zj.lt.0) zj=zj+boxzsize
2279       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2280       xj_safe=xj
2281       yj_safe=yj
2282       zj_safe=zj
2283       isubchap=0
2284       do xshift=-1,1
2285       do yshift=-1,1
2286       do zshift=-1,1
2287           xj=xj_safe+xshift*boxxsize
2288           yj=yj_safe+yshift*boxysize
2289           zj=zj_safe+zshift*boxzsize
2290           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2291           if(dist_temp.lt.dist_init) then
2292             dist_init=dist_temp
2293             xj_temp=xj
2294             yj_temp=yj
2295             zj_temp=zj
2296             isubchap=1
2297           endif
2298        enddo
2299        enddo
2300        enddo
2301        if (isubchap.eq.1) then
2302           xj=xj_temp-xmedi
2303           yj=yj_temp-ymedi
2304           zj=zj_temp-zmedi
2305        else
2306           xj=xj_safe-xmedi
2307           yj=yj_safe-ymedi
2308           zj=zj_safe-zmedi
2309        endif
2310
2311           rij=xj*xj+yj*yj+zj*zj
2312             sss=sscale(sqrt(rij))
2313             sssgrad=sscagrad(sqrt(rij))
2314           rrmij=1.0D0/rij
2315           rij=dsqrt(rij)
2316           rmij=1.0D0/rij
2317           r3ij=rrmij*rmij
2318           r6ij=r3ij*r3ij
2319           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2320           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2321           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2322           fac=cosa-3.0D0*cosb*cosg
2323           ev1=aaa*r6ij*r6ij
2324 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2325           if (j.eq.i+2) ev1=scal_el*ev1
2326           ev2=bbb*r6ij
2327           fac3=ael6i*r6ij
2328           fac4=ael3i*r3ij
2329           evdwij=ev1+ev2
2330           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2331           el2=fac4*fac
2332           eesij=el1+el2
2333 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2334 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2335           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2336           if (shield_mode.gt.0) then
2337 C          fac_shield(i)=0.4
2338 C          fac_shield(j)=0.6
2339 C#define DEBUG
2340 #ifdef DEBUG
2341           write(iout,*) "ees_compon",i,j,el1,el2,
2342      &    fac_shield(i),fac_shield(j)
2343 #endif
2344 C#undef DEBUG
2345           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2346           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2347           eesij=(el1+el2)
2348           ees=ees+eesij
2349           else
2350           fac_shield(i)=1.0
2351           fac_shield(j)=1.0
2352           eesij=(el1+el2)
2353           ees=ees+eesij
2354           endif
2355 C          ees=ees+eesij
2356           evdw1=evdw1+evdwij*sss
2357 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2358 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2359 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2360 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2361 C
2362 C Calculate contributions to the Cartesian gradient.
2363 C
2364 #ifdef SPLITELE
2365           facvdw=-6*rrmij*(ev1+evdwij)*sss
2366           facel=-3*rrmij*(el1+eesij)
2367           fac1=fac
2368           erij(1)=xj*rmij
2369           erij(2)=yj*rmij
2370           erij(3)=zj*rmij
2371           if (calc_grad) then
2372 *
2373 * Radial derivatives. First process both termini of the fragment (i,j)
2374 *
2375           ggg(1)=facel*xj
2376           ggg(2)=facel*yj
2377           ggg(3)=facel*zj
2378
2379           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2380      &  (shield_mode.gt.0)) then
2381 C          print *,i,j
2382           do ilist=1,ishield_list(i)
2383            iresshield=shield_list(ilist,i)
2384            do k=1,3
2385            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2386      &      *2.0
2387            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2388      &              rlocshield
2389      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2390             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2391 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2392 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2393 C             if (iresshield.gt.i) then
2394 C               do ishi=i+1,iresshield-1
2395 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2396 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2397 C
2398 C              enddo
2399 C             else
2400 C               do ishi=iresshield,i
2401 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2402 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2403 C
2404 C               enddo
2405 C              endif
2406 C           enddo
2407 C          enddo
2408            enddo
2409           enddo
2410           do ilist=1,ishield_list(j)
2411            iresshield=shield_list(ilist,j)
2412            do k=1,3
2413            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2414      &     *2.0
2415            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2416      &              rlocshield
2417      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2418            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2419            enddo
2420           enddo
2421
2422           do k=1,3
2423             gshieldc(k,i)=gshieldc(k,i)+
2424      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2425             gshieldc(k,j)=gshieldc(k,j)+
2426      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2427             gshieldc(k,i-1)=gshieldc(k,i-1)+
2428      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2429             gshieldc(k,j-1)=gshieldc(k,j-1)+
2430      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2431
2432            enddo
2433            endif
2434
2435           do k=1,3
2436             ghalf=0.5D0*ggg(k)
2437             gelc(k,i)=gelc(k,i)+ghalf
2438             gelc(k,j)=gelc(k,j)+ghalf
2439           enddo
2440 *
2441 * Loop over residues i+1 thru j-1.
2442 *
2443           do k=i+1,j-1
2444             do l=1,3
2445               gelc(l,k)=gelc(l,k)+ggg(l)
2446             enddo
2447           enddo
2448 C          ggg(1)=facvdw*xj
2449 C          ggg(2)=facvdw*yj
2450 C          ggg(3)=facvdw*zj
2451           if (sss.gt.0.0) then
2452           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2453           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2454           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2455           else
2456           ggg(1)=0.0
2457           ggg(2)=0.0
2458           ggg(3)=0.0
2459           endif
2460           do k=1,3
2461             ghalf=0.5D0*ggg(k)
2462             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2463             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2464           enddo
2465 *
2466 * Loop over residues i+1 thru j-1.
2467 *
2468           do k=i+1,j-1
2469             do l=1,3
2470               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2471             enddo
2472           enddo
2473 #else
2474           facvdw=(ev1+evdwij)*sss
2475           facel=el1+eesij
2476           fac1=fac
2477           fac=-3*rrmij*(facvdw+facvdw+facel)
2478           erij(1)=xj*rmij
2479           erij(2)=yj*rmij
2480           erij(3)=zj*rmij
2481           if (calc_grad) then
2482 *
2483 * Radial derivatives. First process both termini of the fragment (i,j)
2484 *
2485           ggg(1)=fac*xj
2486           ggg(2)=fac*yj
2487           ggg(3)=fac*zj
2488           do k=1,3
2489             ghalf=0.5D0*ggg(k)
2490             gelc(k,i)=gelc(k,i)+ghalf
2491             gelc(k,j)=gelc(k,j)+ghalf
2492           enddo
2493 *
2494 * Loop over residues i+1 thru j-1.
2495 *
2496           do k=i+1,j-1
2497             do l=1,3
2498               gelc(l,k)=gelc(l,k)+ggg(l)
2499             enddo
2500           enddo
2501 #endif
2502 *
2503 * Angular part
2504 *
2505           ecosa=2.0D0*fac3*fac1+fac4
2506           fac4=-3.0D0*fac4
2507           fac3=-6.0D0*fac3
2508           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2509           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2510           do k=1,3
2511             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2512             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2513           enddo
2514 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2515 cd   &          (dcosg(k),k=1,3)
2516           do k=1,3
2517             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2518      &      *fac_shield(i)**2*fac_shield(j)**2
2519           enddo
2520           do k=1,3
2521             ghalf=0.5D0*ggg(k)
2522             gelc(k,i)=gelc(k,i)+ghalf
2523      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2524      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2525      &           *fac_shield(i)**2*fac_shield(j)**2
2526
2527             gelc(k,j)=gelc(k,j)+ghalf
2528      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2529      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2530      &           *fac_shield(i)**2*fac_shield(j)**2
2531           enddo
2532           do k=i+1,j-1
2533             do l=1,3
2534               gelc(l,k)=gelc(l,k)+ggg(l)
2535             enddo
2536           enddo
2537           endif
2538
2539           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2540      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2541      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2542 C
2543 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2544 C   energy of a peptide unit is assumed in the form of a second-order
2545 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2546 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2547 C   are computed for EVERY pair of non-contiguous peptide groups.
2548 C
2549           if (j.lt.nres-1) then
2550             j1=j+1
2551             j2=j-1
2552           else
2553             j1=j-1
2554             j2=j-2
2555           endif
2556           kkk=0
2557           do k=1,2
2558             do l=1,2
2559               kkk=kkk+1
2560               muij(kkk)=mu(k,i)*mu(l,j)
2561             enddo
2562           enddo
2563 cd         write (iout,*) 'EELEC: i',i,' j',j
2564 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2565 cd          write(iout,*) 'muij',muij
2566           ury=scalar(uy(1,i),erij)
2567           urz=scalar(uz(1,i),erij)
2568           vry=scalar(uy(1,j),erij)
2569           vrz=scalar(uz(1,j),erij)
2570           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2571           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2572           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2573           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2574 C For diagnostics only
2575 cd          a22=1.0d0
2576 cd          a23=1.0d0
2577 cd          a32=1.0d0
2578 cd          a33=1.0d0
2579           fac=dsqrt(-ael6i)*r3ij
2580 cd          write (2,*) 'fac=',fac
2581 C For diagnostics only
2582 cd          fac=1.0d0
2583           a22=a22*fac
2584           a23=a23*fac
2585           a32=a32*fac
2586           a33=a33*fac
2587 cd          write (iout,'(4i5,4f10.5)')
2588 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2589 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2590 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2591 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2592 cd          write (iout,'(4f10.5)')
2593 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2594 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2595 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2596 cd           write (iout,'(2i3,9f10.5/)') i,j,
2597 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2598           if (calc_grad) then
2599 C Derivatives of the elements of A in virtual-bond vectors
2600           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2601 cd          do k=1,3
2602 cd            do l=1,3
2603 cd              erder(k,l)=0.0d0
2604 cd            enddo
2605 cd          enddo
2606           do k=1,3
2607             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2608             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2609             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2610             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2611             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2612             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2613             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2614             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2615             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2616             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2617             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2618             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2619           enddo
2620 cd          do k=1,3
2621 cd            do l=1,3
2622 cd              uryg(k,l)=0.0d0
2623 cd              urzg(k,l)=0.0d0
2624 cd              vryg(k,l)=0.0d0
2625 cd              vrzg(k,l)=0.0d0
2626 cd            enddo
2627 cd          enddo
2628 C Compute radial contributions to the gradient
2629           facr=-3.0d0*rrmij
2630           a22der=a22*facr
2631           a23der=a23*facr
2632           a32der=a32*facr
2633           a33der=a33*facr
2634 cd          a22der=0.0d0
2635 cd          a23der=0.0d0
2636 cd          a32der=0.0d0
2637 cd          a33der=0.0d0
2638           agg(1,1)=a22der*xj
2639           agg(2,1)=a22der*yj
2640           agg(3,1)=a22der*zj
2641           agg(1,2)=a23der*xj
2642           agg(2,2)=a23der*yj
2643           agg(3,2)=a23der*zj
2644           agg(1,3)=a32der*xj
2645           agg(2,3)=a32der*yj
2646           agg(3,3)=a32der*zj
2647           agg(1,4)=a33der*xj
2648           agg(2,4)=a33der*yj
2649           agg(3,4)=a33der*zj
2650 C Add the contributions coming from er
2651           fac3=-3.0d0*fac
2652           do k=1,3
2653             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2654             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2655             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2656             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2657           enddo
2658           do k=1,3
2659 C Derivatives in DC(i)
2660             ghalf1=0.5d0*agg(k,1)
2661             ghalf2=0.5d0*agg(k,2)
2662             ghalf3=0.5d0*agg(k,3)
2663             ghalf4=0.5d0*agg(k,4)
2664             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2665      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2666             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2667      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2668             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2669      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2670             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2671      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2672 C Derivatives in DC(i+1)
2673             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2674      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2675             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2676      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2677             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2678      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2679             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2680      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2681 C Derivatives in DC(j)
2682             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2683      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2684             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2685      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2686             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2687      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2688             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2689      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2690 C Derivatives in DC(j+1) or DC(nres-1)
2691             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2692      &      -3.0d0*vryg(k,3)*ury)
2693             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2694      &      -3.0d0*vrzg(k,3)*ury)
2695             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2696      &      -3.0d0*vryg(k,3)*urz)
2697             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2698      &      -3.0d0*vrzg(k,3)*urz)
2699 cd            aggi(k,1)=ghalf1
2700 cd            aggi(k,2)=ghalf2
2701 cd            aggi(k,3)=ghalf3
2702 cd            aggi(k,4)=ghalf4
2703 C Derivatives in DC(i+1)
2704 cd            aggi1(k,1)=agg(k,1)
2705 cd            aggi1(k,2)=agg(k,2)
2706 cd            aggi1(k,3)=agg(k,3)
2707 cd            aggi1(k,4)=agg(k,4)
2708 C Derivatives in DC(j)
2709 cd            aggj(k,1)=ghalf1
2710 cd            aggj(k,2)=ghalf2
2711 cd            aggj(k,3)=ghalf3
2712 cd            aggj(k,4)=ghalf4
2713 C Derivatives in DC(j+1)
2714 cd            aggj1(k,1)=0.0d0
2715 cd            aggj1(k,2)=0.0d0
2716 cd            aggj1(k,3)=0.0d0
2717 cd            aggj1(k,4)=0.0d0
2718             if (j.eq.nres-1 .and. i.lt.j-2) then
2719               do l=1,4
2720                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2721 cd                aggj1(k,l)=agg(k,l)
2722               enddo
2723             endif
2724           enddo
2725           endif
2726 c          goto 11111
2727 C Check the loc-el terms by numerical integration
2728           acipa(1,1)=a22
2729           acipa(1,2)=a23
2730           acipa(2,1)=a32
2731           acipa(2,2)=a33
2732           a22=-a22
2733           a23=-a23
2734           do l=1,2
2735             do k=1,3
2736               agg(k,l)=-agg(k,l)
2737               aggi(k,l)=-aggi(k,l)
2738               aggi1(k,l)=-aggi1(k,l)
2739               aggj(k,l)=-aggj(k,l)
2740               aggj1(k,l)=-aggj1(k,l)
2741             enddo
2742           enddo
2743           if (j.lt.nres-1) then
2744             a22=-a22
2745             a32=-a32
2746             do l=1,3,2
2747               do k=1,3
2748                 agg(k,l)=-agg(k,l)
2749                 aggi(k,l)=-aggi(k,l)
2750                 aggi1(k,l)=-aggi1(k,l)
2751                 aggj(k,l)=-aggj(k,l)
2752                 aggj1(k,l)=-aggj1(k,l)
2753               enddo
2754             enddo
2755           else
2756             a22=-a22
2757             a23=-a23
2758             a32=-a32
2759             a33=-a33
2760             do l=1,4
2761               do k=1,3
2762                 agg(k,l)=-agg(k,l)
2763                 aggi(k,l)=-aggi(k,l)
2764                 aggi1(k,l)=-aggi1(k,l)
2765                 aggj(k,l)=-aggj(k,l)
2766                 aggj1(k,l)=-aggj1(k,l)
2767               enddo
2768             enddo
2769           endif
2770           ENDIF ! WCORR
2771 11111     continue
2772           IF (wel_loc.gt.0.0d0) THEN
2773 C Contribution to the local-electrostatic energy coming from the i-j pair
2774           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2775      &     +a33*muij(4)
2776 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2777 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2778           if (shield_mode.eq.0) then
2779            fac_shield(i)=1.0
2780            fac_shield(j)=1.0
2781 C          else
2782 C           fac_shield(i)=0.4
2783 C           fac_shield(j)=0.6
2784           endif
2785           eel_loc_ij=eel_loc_ij
2786      &    *fac_shield(i)*fac_shield(j)
2787           eel_loc=eel_loc+eel_loc_ij
2788 C Partial derivatives in virtual-bond dihedral angles gamma
2789           if (calc_grad) then
2790           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2791      &  (shield_mode.gt.0)) then
2792 C          print *,i,j
2793
2794           do ilist=1,ishield_list(i)
2795            iresshield=shield_list(ilist,i)
2796            do k=1,3
2797            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2798      &                                          /fac_shield(i)
2799 C     &      *2.0
2800            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2801      &              rlocshield
2802      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2803             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2804      &      +rlocshield
2805            enddo
2806           enddo
2807           do ilist=1,ishield_list(j)
2808            iresshield=shield_list(ilist,j)
2809            do k=1,3
2810            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2811      &                                       /fac_shield(j)
2812 C     &     *2.0
2813            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2814      &              rlocshield
2815      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2816            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2817      &             +rlocshield
2818
2819            enddo
2820           enddo
2821           do k=1,3
2822             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2823      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2824             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2825      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2826             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2827      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2828             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2829      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2830            enddo
2831            endif
2832           if (i.gt.1)
2833      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2834      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2835      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2836      &    *fac_shield(i)*fac_shield(j)
2837           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2838      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2839      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2840      &    *fac_shield(i)*fac_shield(j)
2841
2842 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2843 cd          write(iout,*) 'agg  ',agg
2844 cd          write(iout,*) 'aggi ',aggi
2845 cd          write(iout,*) 'aggi1',aggi1
2846 cd          write(iout,*) 'aggj ',aggj
2847 cd          write(iout,*) 'aggj1',aggj1
2848
2849 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2850           do l=1,3
2851             ggg(l)=agg(l,1)*muij(1)+
2852      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2853      &    *fac_shield(i)*fac_shield(j)
2854
2855           enddo
2856           do k=i+2,j2
2857             do l=1,3
2858               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2859             enddo
2860           enddo
2861 C Remaining derivatives of eello
2862           do l=1,3
2863             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2864      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2865      &    *fac_shield(i)*fac_shield(j)
2866
2867             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2868      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2869      &    *fac_shield(i)*fac_shield(j)
2870
2871             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2872      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2873      &    *fac_shield(i)*fac_shield(j)
2874
2875             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2876      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2877      &    *fac_shield(i)*fac_shield(j)
2878
2879           enddo
2880           endif
2881           ENDIF
2882           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2883 C Contributions from turns
2884             a_temp(1,1)=a22
2885             a_temp(1,2)=a23
2886             a_temp(2,1)=a32
2887             a_temp(2,2)=a33
2888             call eturn34(i,j,eello_turn3,eello_turn4)
2889           endif
2890 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2891           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2892 C
2893 C Calculate the contact function. The ith column of the array JCONT will
2894 C contain the numbers of atoms that make contacts with the atom I (of numbers
2895 C greater than I). The arrays FACONT and GACONT will contain the values of
2896 C the contact function and its derivative.
2897 c           r0ij=1.02D0*rpp(iteli,itelj)
2898 c           r0ij=1.11D0*rpp(iteli,itelj)
2899             r0ij=2.20D0*rpp(iteli,itelj)
2900 c           r0ij=1.55D0*rpp(iteli,itelj)
2901             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2902             if (fcont.gt.0.0D0) then
2903               num_conti=num_conti+1
2904               if (num_conti.gt.maxconts) then
2905                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2906      &                         ' will skip next contacts for this conf.'
2907               else
2908                 jcont_hb(num_conti,i)=j
2909                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2910      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2911 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2912 C  terms.
2913                 d_cont(num_conti,i)=rij
2914 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2915 C     --- Electrostatic-interaction matrix ---
2916                 a_chuj(1,1,num_conti,i)=a22
2917                 a_chuj(1,2,num_conti,i)=a23
2918                 a_chuj(2,1,num_conti,i)=a32
2919                 a_chuj(2,2,num_conti,i)=a33
2920 C     --- Gradient of rij
2921                 do kkk=1,3
2922                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2923                 enddo
2924 c             if (i.eq.1) then
2925 c                a_chuj(1,1,num_conti,i)=-0.61d0
2926 c                a_chuj(1,2,num_conti,i)= 0.4d0
2927 c                a_chuj(2,1,num_conti,i)= 0.65d0
2928 c                a_chuj(2,2,num_conti,i)= 0.50d0
2929 c             else if (i.eq.2) then
2930 c                a_chuj(1,1,num_conti,i)= 0.0d0
2931 c                a_chuj(1,2,num_conti,i)= 0.0d0
2932 c                a_chuj(2,1,num_conti,i)= 0.0d0
2933 c                a_chuj(2,2,num_conti,i)= 0.0d0
2934 c             endif
2935 C     --- and its gradients
2936 cd                write (iout,*) 'i',i,' j',j
2937 cd                do kkk=1,3
2938 cd                write (iout,*) 'iii 1 kkk',kkk
2939 cd                write (iout,*) agg(kkk,:)
2940 cd                enddo
2941 cd                do kkk=1,3
2942 cd                write (iout,*) 'iii 2 kkk',kkk
2943 cd                write (iout,*) aggi(kkk,:)
2944 cd                enddo
2945 cd                do kkk=1,3
2946 cd                write (iout,*) 'iii 3 kkk',kkk
2947 cd                write (iout,*) aggi1(kkk,:)
2948 cd                enddo
2949 cd                do kkk=1,3
2950 cd                write (iout,*) 'iii 4 kkk',kkk
2951 cd                write (iout,*) aggj(kkk,:)
2952 cd                enddo
2953 cd                do kkk=1,3
2954 cd                write (iout,*) 'iii 5 kkk',kkk
2955 cd                write (iout,*) aggj1(kkk,:)
2956 cd                enddo
2957                 kkll=0
2958                 do k=1,2
2959                   do l=1,2
2960                     kkll=kkll+1
2961                     do m=1,3
2962                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2963                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2964                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2965                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2966                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2967 c                      do mm=1,5
2968 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2969 c                      enddo
2970                     enddo
2971                   enddo
2972                 enddo
2973                 ENDIF
2974                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2975 C Calculate contact energies
2976                 cosa4=4.0D0*cosa
2977                 wij=cosa-3.0D0*cosb*cosg
2978                 cosbg1=cosb+cosg
2979                 cosbg2=cosb-cosg
2980 c               fac3=dsqrt(-ael6i)/r0ij**3
2981                 fac3=dsqrt(-ael6i)*r3ij
2982                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2983                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2984                 if (shield_mode.eq.0) then
2985                 fac_shield(i)=1.0d0
2986                 fac_shield(j)=1.0d0
2987                 else
2988                 ees0plist(num_conti,i)=j
2989 C                fac_shield(i)=0.4d0
2990 C                fac_shield(j)=0.6d0
2991                 endif
2992 c               ees0mij=0.0D0
2993                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2994      &          *fac_shield(i)*fac_shield(j)
2995
2996                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2997      &          *fac_shield(i)*fac_shield(j)
2998
2999 C Diagnostics. Comment out or remove after debugging!
3000 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3001 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3002 c               ees0m(num_conti,i)=0.0D0
3003 C End diagnostics.
3004 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3005 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3006                 facont_hb(num_conti,i)=fcont
3007                 if (calc_grad) then
3008 C Angular derivatives of the contact function
3009                 ees0pij1=fac3/ees0pij
3010                 ees0mij1=fac3/ees0mij
3011                 fac3p=-3.0D0*fac3*rrmij
3012                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3013                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3014 c               ees0mij1=0.0D0
3015                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3016                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3017                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3018                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3019                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3020                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3021                 ecosap=ecosa1+ecosa2
3022                 ecosbp=ecosb1+ecosb2
3023                 ecosgp=ecosg1+ecosg2
3024                 ecosam=ecosa1-ecosa2
3025                 ecosbm=ecosb1-ecosb2
3026                 ecosgm=ecosg1-ecosg2
3027 C Diagnostics
3028 c               ecosap=ecosa1
3029 c               ecosbp=ecosb1
3030 c               ecosgp=ecosg1
3031 c               ecosam=0.0D0
3032 c               ecosbm=0.0D0
3033 c               ecosgm=0.0D0
3034 C End diagnostics
3035                 fprimcont=fprimcont/rij
3036 cd              facont_hb(num_conti,i)=1.0D0
3037 C Following line is for diagnostics.
3038 cd              fprimcont=0.0D0
3039                 do k=1,3
3040                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3041                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3042                 enddo
3043                 do k=1,3
3044                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3045                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3046                 enddo
3047                 gggp(1)=gggp(1)+ees0pijp*xj
3048                 gggp(2)=gggp(2)+ees0pijp*yj
3049                 gggp(3)=gggp(3)+ees0pijp*zj
3050                 gggm(1)=gggm(1)+ees0mijp*xj
3051                 gggm(2)=gggm(2)+ees0mijp*yj
3052                 gggm(3)=gggm(3)+ees0mijp*zj
3053 C Derivatives due to the contact function
3054                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3055                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3056                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3057                 do k=1,3
3058                   ghalfp=0.5D0*gggp(k)
3059                   ghalfm=0.5D0*gggm(k)
3060                   gacontp_hb1(k,num_conti,i)=ghalfp
3061      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3062      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3063      &          *fac_shield(i)*fac_shield(j)
3064
3065                   gacontp_hb2(k,num_conti,i)=ghalfp
3066      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3067      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3068      &          *fac_shield(i)*fac_shield(j)
3069
3070                   gacontp_hb3(k,num_conti,i)=gggp(k)
3071      &          *fac_shield(i)*fac_shield(j)
3072
3073                   gacontm_hb1(k,num_conti,i)=ghalfm
3074      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3075      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3076      &          *fac_shield(i)*fac_shield(j)
3077
3078                   gacontm_hb2(k,num_conti,i)=ghalfm
3079      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3080      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3081      &          *fac_shield(i)*fac_shield(j)
3082
3083                   gacontm_hb3(k,num_conti,i)=gggm(k)
3084      &          *fac_shield(i)*fac_shield(j)
3085
3086                 enddo
3087                 endif
3088 C Diagnostics. Comment out or remove after debugging!
3089 cdiag           do k=1,3
3090 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3091 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3092 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3093 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3094 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3095 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3096 cdiag           enddo
3097               ENDIF ! wcorr
3098               endif  ! num_conti.le.maxconts
3099             endif  ! fcont.gt.0
3100           endif    ! j.gt.i+1
3101  1216     continue
3102         enddo ! j
3103         num_cont_hb(i)=num_conti
3104  1215   continue
3105       enddo   ! i
3106 cd      do i=1,nres
3107 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3108 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3109 cd      enddo
3110 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3111 ccc      eel_loc=eel_loc+eello_turn3
3112       return
3113       end
3114 C-----------------------------------------------------------------------------
3115       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3116 C Third- and fourth-order contributions from turns
3117       implicit real*8 (a-h,o-z)
3118       include 'DIMENSIONS'
3119       include 'sizesclu.dat'
3120       include 'COMMON.IOUNITS'
3121       include 'COMMON.GEO'
3122       include 'COMMON.VAR'
3123       include 'COMMON.LOCAL'
3124       include 'COMMON.CHAIN'
3125       include 'COMMON.DERIV'
3126       include 'COMMON.INTERACT'
3127       include 'COMMON.CONTACTS'
3128       include 'COMMON.TORSION'
3129       include 'COMMON.VECTORS'
3130       include 'COMMON.FFIELD'
3131       include 'COMMON.SHIELD'
3132       include 'COMMON.CONTROL'
3133
3134       dimension ggg(3)
3135       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3136      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3137      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3138       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3139      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3140       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3141       if (j.eq.i+2) then
3142       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3143 C changes suggested by Ana to avoid out of bounds
3144 C     & .or.((i+5).gt.nres)
3145 C     & .or.((i-1).le.0)
3146 C end of changes suggested by Ana
3147      &    .or. itype(i+2).eq.ntyp1
3148      &    .or. itype(i+3).eq.ntyp1
3149 C     &    .or. itype(i+5).eq.ntyp1
3150 C     &    .or. itype(i).eq.ntyp1
3151 C     &    .or. itype(i-1).eq.ntyp1
3152      &    ) goto 179
3153
3154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3155 C
3156 C               Third-order contributions
3157 C
3158 C                 (i+2)o----(i+3)
3159 C                      | |
3160 C                      | |
3161 C                 (i+1)o----i
3162 C
3163 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3164 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3165         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3166         call transpose2(auxmat(1,1),auxmat1(1,1))
3167         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3168         if (shield_mode.eq.0) then
3169         fac_shield(i)=1.0
3170         fac_shield(j)=1.0
3171 C        else
3172 C        fac_shield(i)=0.4
3173 C        fac_shield(j)=0.6
3174         endif
3175         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3176      &  *fac_shield(i)*fac_shield(j)
3177         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3178      &  *fac_shield(i)*fac_shield(j)
3179
3180 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3181 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3182 cd     &    ' eello_turn3_num',4*eello_turn3_num
3183         if (calc_grad) then
3184 C Derivatives in shield mode
3185           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3186      &  (shield_mode.gt.0)) then
3187 C          print *,i,j
3188
3189           do ilist=1,ishield_list(i)
3190            iresshield=shield_list(ilist,i)
3191            do k=1,3
3192            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3193 C     &      *2.0
3194            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3195      &              rlocshield
3196      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3197             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3198      &      +rlocshield
3199            enddo
3200           enddo
3201           do ilist=1,ishield_list(j)
3202            iresshield=shield_list(ilist,j)
3203            do k=1,3
3204            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3205 C     &     *2.0
3206            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3207      &              rlocshield
3208      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3209            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3210      &             +rlocshield
3211
3212            enddo
3213           enddo
3214
3215           do k=1,3
3216             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3217      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3218             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3219      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3220             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3221      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3222             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3223      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3224            enddo
3225            endif
3226
3227 C Derivatives in gamma(i)
3228         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3229         call transpose2(auxmat2(1,1),pizda(1,1))
3230         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3231         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3232      &   *fac_shield(i)*fac_shield(j)
3233
3234 C Derivatives in gamma(i+1)
3235         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3236         call transpose2(auxmat2(1,1),pizda(1,1))
3237         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3238         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3239      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3240      &   *fac_shield(i)*fac_shield(j)
3241
3242 C Cartesian derivatives
3243         do l=1,3
3244           a_temp(1,1)=aggi(l,1)
3245           a_temp(1,2)=aggi(l,2)
3246           a_temp(2,1)=aggi(l,3)
3247           a_temp(2,2)=aggi(l,4)
3248           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3249           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3250      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3251      &   *fac_shield(i)*fac_shield(j)
3252
3253           a_temp(1,1)=aggi1(l,1)
3254           a_temp(1,2)=aggi1(l,2)
3255           a_temp(2,1)=aggi1(l,3)
3256           a_temp(2,2)=aggi1(l,4)
3257           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3258           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3259      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3260      &   *fac_shield(i)*fac_shield(j)
3261
3262           a_temp(1,1)=aggj(l,1)
3263           a_temp(1,2)=aggj(l,2)
3264           a_temp(2,1)=aggj(l,3)
3265           a_temp(2,2)=aggj(l,4)
3266           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3267           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3268      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3269      &   *fac_shield(i)*fac_shield(j)
3270
3271           a_temp(1,1)=aggj1(l,1)
3272           a_temp(1,2)=aggj1(l,2)
3273           a_temp(2,1)=aggj1(l,3)
3274           a_temp(2,2)=aggj1(l,4)
3275           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3276           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3277      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3278      &   *fac_shield(i)*fac_shield(j)
3279
3280         enddo
3281         endif
3282   179 continue
3283       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3284       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3285 C changes suggested by Ana to avoid out of bounds
3286 C     & .or.((i+5).gt.nres)
3287 C     & .or.((i-1).le.0)
3288 C end of changes suggested by Ana
3289      &    .or. itype(i+3).eq.ntyp1
3290      &    .or. itype(i+4).eq.ntyp1
3291 C     &    .or. itype(i+5).eq.ntyp1
3292      &    .or. itype(i).eq.ntyp1
3293 C     &    .or. itype(i-1).eq.ntyp1
3294      &    ) goto 178
3295
3296 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3297 C
3298 C               Fourth-order contributions
3299 C
3300 C                 (i+3)o----(i+4)
3301 C                     /  |
3302 C               (i+2)o   |
3303 C                     \  |
3304 C                 (i+1)o----i
3305 C
3306 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3307 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3308         iti1=itortyp(itype(i+1))
3309         iti2=itortyp(itype(i+2))
3310         iti3=itortyp(itype(i+3))
3311         call transpose2(EUg(1,1,i+1),e1t(1,1))
3312         call transpose2(Eug(1,1,i+2),e2t(1,1))
3313         call transpose2(Eug(1,1,i+3),e3t(1,1))
3314         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3315         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3316         s1=scalar2(b1(1,iti2),auxvec(1))
3317         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3318         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3319         s2=scalar2(b1(1,iti1),auxvec(1))
3320         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3321         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3322         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3323         if (shield_mode.eq.0) then
3324         fac_shield(i)=1.0
3325         fac_shield(j)=1.0
3326 C        else
3327 C        fac_shield(i)=0.4
3328 C        fac_shield(j)=0.6
3329         endif
3330         eello_turn4=eello_turn4-(s1+s2+s3)
3331      &  *fac_shield(i)*fac_shield(j)
3332         eello_t4=-(s1+s2+s3)
3333      &  *fac_shield(i)*fac_shield(j)
3334
3335 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3336 cd     &    ' eello_turn4_num',8*eello_turn4_num
3337 C Derivatives in gamma(i)
3338         if (calc_grad) then
3339           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3340      &  (shield_mode.gt.0)) then
3341 C          print *,i,j
3342
3343           do ilist=1,ishield_list(i)
3344            iresshield=shield_list(ilist,i)
3345            do k=1,3
3346            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3347 C     &      *2.0
3348            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3349      &              rlocshield
3350      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3351             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3352      &      +rlocshield
3353            enddo
3354           enddo
3355           do ilist=1,ishield_list(j)
3356            iresshield=shield_list(ilist,j)
3357            do k=1,3
3358            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3359 C     &     *2.0
3360            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3361      &              rlocshield
3362      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3363            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3364      &             +rlocshield
3365
3366            enddo
3367           enddo
3368
3369           do k=1,3
3370             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3371      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3372             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3373      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3374             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3375      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3376             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3377      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3378            enddo
3379            endif
3380
3381         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3382         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3383         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3384         s1=scalar2(b1(1,iti2),auxvec(1))
3385         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3386         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3387         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3388      &  *fac_shield(i)*fac_shield(j)
3389
3390 C Derivatives in gamma(i+1)
3391         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3392         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3393         s2=scalar2(b1(1,iti1),auxvec(1))
3394         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3395         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3396         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3397         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3398      &  *fac_shield(i)*fac_shield(j)
3399
3400 C Derivatives in gamma(i+2)
3401         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3402         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3403         s1=scalar2(b1(1,iti2),auxvec(1))
3404         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3405         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3406         s2=scalar2(b1(1,iti1),auxvec(1))
3407         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3408         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3409         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3410         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3411      &  *fac_shield(i)*fac_shield(j)
3412
3413 C Cartesian derivatives
3414 C Derivatives of this turn contributions in DC(i+2)
3415         if (j.lt.nres-1) then
3416           do l=1,3
3417             a_temp(1,1)=agg(l,1)
3418             a_temp(1,2)=agg(l,2)
3419             a_temp(2,1)=agg(l,3)
3420             a_temp(2,2)=agg(l,4)
3421             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3422             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3423             s1=scalar2(b1(1,iti2),auxvec(1))
3424             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3425             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3426             s2=scalar2(b1(1,iti1),auxvec(1))
3427             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3428             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3429             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3430             ggg(l)=-(s1+s2+s3)
3431             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3432      &  *fac_shield(i)*fac_shield(j)
3433
3434           enddo
3435         endif
3436 C Remaining derivatives of this turn contribution
3437         do l=1,3
3438           a_temp(1,1)=aggi(l,1)
3439           a_temp(1,2)=aggi(l,2)
3440           a_temp(2,1)=aggi(l,3)
3441           a_temp(2,2)=aggi(l,4)
3442           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3443           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3444           s1=scalar2(b1(1,iti2),auxvec(1))
3445           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3446           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3447           s2=scalar2(b1(1,iti1),auxvec(1))
3448           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3449           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3450           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3451           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3452      &  *fac_shield(i)*fac_shield(j)
3453
3454           a_temp(1,1)=aggi1(l,1)
3455           a_temp(1,2)=aggi1(l,2)
3456           a_temp(2,1)=aggi1(l,3)
3457           a_temp(2,2)=aggi1(l,4)
3458           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3459           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3460           s1=scalar2(b1(1,iti2),auxvec(1))
3461           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3462           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3463           s2=scalar2(b1(1,iti1),auxvec(1))
3464           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3465           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3466           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3467           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3468      &  *fac_shield(i)*fac_shield(j)
3469
3470           a_temp(1,1)=aggj(l,1)
3471           a_temp(1,2)=aggj(l,2)
3472           a_temp(2,1)=aggj(l,3)
3473           a_temp(2,2)=aggj(l,4)
3474           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3475           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3476           s1=scalar2(b1(1,iti2),auxvec(1))
3477           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3478           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3479           s2=scalar2(b1(1,iti1),auxvec(1))
3480           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3481           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3482           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3483           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3484      &  *fac_shield(i)*fac_shield(j)
3485
3486           a_temp(1,1)=aggj1(l,1)
3487           a_temp(1,2)=aggj1(l,2)
3488           a_temp(2,1)=aggj1(l,3)
3489           a_temp(2,2)=aggj1(l,4)
3490           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3491           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3492           s1=scalar2(b1(1,iti2),auxvec(1))
3493           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3494           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3495           s2=scalar2(b1(1,iti1),auxvec(1))
3496           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3497           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3498           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3499           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3500      &  *fac_shield(i)*fac_shield(j)
3501
3502         enddo
3503         endif
3504   178 continue
3505       endif
3506       return
3507       end
3508 C-----------------------------------------------------------------------------
3509       subroutine vecpr(u,v,w)
3510       implicit real*8(a-h,o-z)
3511       dimension u(3),v(3),w(3)
3512       w(1)=u(2)*v(3)-u(3)*v(2)
3513       w(2)=-u(1)*v(3)+u(3)*v(1)
3514       w(3)=u(1)*v(2)-u(2)*v(1)
3515       return
3516       end
3517 C-----------------------------------------------------------------------------
3518       subroutine unormderiv(u,ugrad,unorm,ungrad)
3519 C This subroutine computes the derivatives of a normalized vector u, given
3520 C the derivatives computed without normalization conditions, ugrad. Returns
3521 C ungrad.
3522       implicit none
3523       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3524       double precision vec(3)
3525       double precision scalar
3526       integer i,j
3527 c      write (2,*) 'ugrad',ugrad
3528 c      write (2,*) 'u',u
3529       do i=1,3
3530         vec(i)=scalar(ugrad(1,i),u(1))
3531       enddo
3532 c      write (2,*) 'vec',vec
3533       do i=1,3
3534         do j=1,3
3535           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3536         enddo
3537       enddo
3538 c      write (2,*) 'ungrad',ungrad
3539       return
3540       end
3541 C-----------------------------------------------------------------------------
3542       subroutine escp(evdw2,evdw2_14)
3543 C
3544 C This subroutine calculates the excluded-volume interaction energy between
3545 C peptide-group centers and side chains and its gradient in virtual-bond and
3546 C side-chain vectors.
3547 C
3548       implicit real*8 (a-h,o-z)
3549       include 'DIMENSIONS'
3550       include 'sizesclu.dat'
3551       include 'COMMON.GEO'
3552       include 'COMMON.VAR'
3553       include 'COMMON.LOCAL'
3554       include 'COMMON.CHAIN'
3555       include 'COMMON.DERIV'
3556       include 'COMMON.INTERACT'
3557       include 'COMMON.FFIELD'
3558       include 'COMMON.IOUNITS'
3559       integer xshift,yshift,zshift
3560       dimension ggg(3)
3561       evdw2=0.0D0
3562       evdw2_14=0.0d0
3563 cd    print '(a)','Enter ESCP'
3564 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3565 c     &  ' scal14',scal14
3566       do i=iatscp_s,iatscp_e
3567         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3568         iteli=itel(i)
3569 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3570 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3571         if (iteli.eq.0) goto 1225
3572         xi=0.5D0*(c(1,i)+c(1,i+1))
3573         yi=0.5D0*(c(2,i)+c(2,i+1))
3574         zi=0.5D0*(c(3,i)+c(3,i+1))
3575 C    Returning the ith atom to box
3576           xi=mod(xi,boxxsize)
3577           if (xi.lt.0) xi=xi+boxxsize
3578           yi=mod(yi,boxysize)
3579           if (yi.lt.0) yi=yi+boxysize
3580           zi=mod(zi,boxzsize)
3581           if (zi.lt.0) zi=zi+boxzsize
3582
3583         do iint=1,nscp_gr(i)
3584
3585         do j=iscpstart(i,iint),iscpend(i,iint)
3586           itypj=iabs(itype(j))
3587           if (itypj.eq.ntyp1) cycle
3588 C Uncomment following three lines for SC-p interactions
3589 c         xj=c(1,nres+j)-xi
3590 c         yj=c(2,nres+j)-yi
3591 c         zj=c(3,nres+j)-zi
3592 C Uncomment following three lines for Ca-p interactions
3593           xj=c(1,j)
3594           yj=c(2,j)
3595           zj=c(3,j)
3596 C returning the jth atom to box
3597           xj=mod(xj,boxxsize)
3598           if (xj.lt.0) xj=xj+boxxsize
3599           yj=mod(yj,boxysize)
3600           if (yj.lt.0) yj=yj+boxysize
3601           zj=mod(zj,boxzsize)
3602           if (zj.lt.0) zj=zj+boxzsize
3603       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3604       xj_safe=xj
3605       yj_safe=yj
3606       zj_safe=zj
3607       subchap=0
3608 C Finding the closest jth atom
3609       do xshift=-1,1
3610       do yshift=-1,1
3611       do zshift=-1,1
3612           xj=xj_safe+xshift*boxxsize
3613           yj=yj_safe+yshift*boxysize
3614           zj=zj_safe+zshift*boxzsize
3615           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3616           if(dist_temp.lt.dist_init) then
3617             dist_init=dist_temp
3618             xj_temp=xj
3619             yj_temp=yj
3620             zj_temp=zj
3621             subchap=1
3622           endif
3623        enddo
3624        enddo
3625        enddo
3626        if (subchap.eq.1) then
3627           xj=xj_temp-xi
3628           yj=yj_temp-yi
3629           zj=zj_temp-zi
3630        else
3631           xj=xj_safe-xi
3632           yj=yj_safe-yi
3633           zj=zj_safe-zi
3634        endif
3635
3636           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3637 C sss is scaling function for smoothing the cutoff gradient otherwise
3638 C the gradient would not be continuouse
3639           sss=sscale(1.0d0/(dsqrt(rrij)))
3640           if (sss.le.0.0d0) cycle
3641           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3642           fac=rrij**expon2
3643           e1=fac*fac*aad(itypj,iteli)
3644           e2=fac*bad(itypj,iteli)
3645           if (iabs(j-i) .le. 2) then
3646             e1=scal14*e1
3647             e2=scal14*e2
3648             evdw2_14=evdw2_14+(e1+e2)*sss
3649           endif
3650           evdwij=e1+e2
3651 c          write (iout,*) i,j,evdwij
3652           evdw2=evdw2+evdwij*sss
3653           if (calc_grad) then
3654 C
3655 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3656 C
3657            fac=-(evdwij+e1)*rrij*sss
3658            fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3659           ggg(1)=xj*fac
3660           ggg(2)=yj*fac
3661           ggg(3)=zj*fac
3662           if (j.lt.i) then
3663 cd          write (iout,*) 'j<i'
3664 C Uncomment following three lines for SC-p interactions
3665 c           do k=1,3
3666 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3667 c           enddo
3668           else
3669 cd          write (iout,*) 'j>i'
3670             do k=1,3
3671               ggg(k)=-ggg(k)
3672 C Uncomment following line for SC-p interactions
3673 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3674             enddo
3675           endif
3676           do k=1,3
3677             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3678           enddo
3679           kstart=min0(i+1,j)
3680           kend=max0(i-1,j-1)
3681 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3682 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3683           do k=kstart,kend
3684             do l=1,3
3685               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3686             enddo
3687           enddo
3688           endif
3689         enddo
3690         enddo ! iint
3691  1225   continue
3692       enddo ! i
3693       do i=1,nct
3694         do j=1,3
3695           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3696           gradx_scp(j,i)=expon*gradx_scp(j,i)
3697         enddo
3698       enddo
3699 C******************************************************************************
3700 C
3701 C                              N O T E !!!
3702 C
3703 C To save time the factor EXPON has been extracted from ALL components
3704 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3705 C use!
3706 C
3707 C******************************************************************************
3708       return
3709       end
3710 C--------------------------------------------------------------------------
3711       subroutine edis(ehpb)
3712 C
3713 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3714 C
3715       implicit real*8 (a-h,o-z)
3716       include 'DIMENSIONS'
3717       include 'COMMON.SBRIDGE'
3718       include 'COMMON.CHAIN'
3719       include 'COMMON.DERIV'
3720       include 'COMMON.VAR'
3721       include 'COMMON.INTERACT'
3722       include 'COMMON.CONTROL'
3723       include 'COMMON.IOUNITS'
3724       dimension ggg(3),ggg_peak(3,100)
3725       ehpb=0.0D0
3726       ggg=0.0d0
3727 C      write (iout,*) ,"link_end",link_end,constr_dist
3728 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
3729 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
3730 c     &  " constr_dist",constr_dist
3731       if (link_end.eq.0.and.link_end_peak.eq.0) return
3732       do i=link_start_peak,link_end_peak
3733         ehpb_peak=0.0d0
3734 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
3735 c     &   ipeak(1,i),ipeak(2,i)
3736         do ip=ipeak(1,i),ipeak(2,i)
3737           ii=ihpb_peak(ip)
3738           jj=jhpb_peak(ip)
3739           dd=dist(ii,jj)
3740           iip=ip-ipeak(1,i)+1
3741 C iii and jjj point to the residues for which the distance is assigned.
3742           if (ii.gt.nres) then
3743             iii=ii-nres
3744             jjj=jj-nres
3745           else
3746             iii=ii
3747             jjj=jj
3748           endif
3749           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
3750           aux=dexp(-scal_peak*aux)
3751           ehpb_peak=ehpb_peak+aux
3752           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
3753      &      forcon_peak(ip))*aux/dd
3754           do j=1,3
3755             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
3756           enddo
3757           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
3758      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
3759      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
3760         enddo
3761 c        write (iout,*) ii,iip,iii,jjj,"ehpb_peak",ehpb_peak,
3762 c     &     " scal_peak",scal_peak
3763         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
3764         do ip=ipeak(1,i),ipeak(2,i)
3765           iip=ip-ipeak(1,i)+1
3766           do j=1,3
3767             ggg(j)=ggg_peak(j,iip)/ehpb_peak
3768           enddo
3769           ii=ihpb_peak(ip)
3770           jj=jhpb_peak(ip)
3771 C iii and jjj point to the residues for which the distance is assigned.
3772           if (ii.gt.nres) then
3773             iii=ii-nres
3774             jjj=jj-nres
3775           else
3776             iii=ii
3777             jjj=jj
3778           endif
3779           if (iii.lt.ii) then
3780             do j=1,3
3781               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3782               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3783             enddo
3784           endif
3785           do k=1,3
3786             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3787             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3788           enddo
3789         enddo
3790       enddo
3791       do i=link_start,link_end
3792 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3793 C CA-CA distance used in regularization of structure.
3794         ii=ihpb(i)
3795         jj=jhpb(i)
3796 C iii and jjj point to the residues for which the distance is assigned.
3797         if (ii.gt.nres) then
3798           iii=ii-nres
3799           jjj=jj-nres
3800         else
3801           iii=ii
3802           jjj=jj
3803         endif
3804 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
3805 c     &    dhpb(i),dhpb1(i),forcon(i)
3806 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3807 C    distance and angle dependent SS bond potential.
3808 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3809 C     & iabs(itype(jjj)).eq.1) then
3810 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3811 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
3812         if (.not.dyn_ss .and. i.le.nss) then
3813 C 15/02/13 CC dynamic SSbond - additional check
3814           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3815      &        iabs(itype(jjj)).eq.1) then
3816            call ssbond_ene(iii,jjj,eij)
3817            ehpb=ehpb+2*eij
3818          endif
3819 cd          write (iout,*) "eij",eij
3820 cd   &   ' waga=',waga,' fac=',fac
3821 !        else if (ii.gt.nres .and. jj.gt.nres) then
3822         else
3823 C Calculate the distance between the two points and its difference from the
3824 C target distance.
3825           dd=dist(ii,jj)
3826           if (irestr_type(i).eq.11) then
3827             ehpb=ehpb+fordepth(i)!**4.0d0
3828      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3829             fac=fordepth(i)!**4.0d0
3830      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3831 c            if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
3832 c     &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
3833 c     &        ehpb,irestr_type(i)
3834           else if (irestr_type(i).eq.10) then
3835 c AL 6//19/2018 cross-link restraints
3836             xdis = 0.5d0*(dd/forcon(i))**2
3837             expdis = dexp(-xdis)
3838 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
3839             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
3840 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
3841 c     &          " wboltzd",wboltzd
3842             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
3843 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
3844             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
3845      &           *expdis/(aux*forcon(i)**2)
3846 c            if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
3847 c     &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
3848 c     &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
3849           else if (irestr_type(i).eq.2) then
3850 c Quartic restraints
3851             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3852 c            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
3853 c     &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
3854 c     &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
3855             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3856           else
3857 c Quadratic restraints
3858             rdis=dd-dhpb(i)
3859 C Get the force constant corresponding to this distance.
3860             waga=forcon(i)
3861 C Calculate the contribution to energy.
3862             ehpb=ehpb+0.5d0*waga*rdis*rdis
3863 c            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
3864 c     &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
3865 c     &       0.5d0*waga*rdis*rdis,irestr_type(i)
3866 C
3867 C Evaluate gradient.
3868 C
3869             fac=waga*rdis/dd
3870           endif
3871 c Calculate Cartesian gradient
3872           do j=1,3
3873             ggg(j)=fac*(c(j,jj)-c(j,ii))
3874           enddo
3875 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3876 C If this is a SC-SC distance, we need to calculate the contributions to the
3877 C Cartesian gradient in the SC vectors (ghpbx).
3878           if (iii.lt.ii) then
3879             do j=1,3
3880               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3881               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3882             enddo
3883           endif
3884           do k=1,3
3885             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3886             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3887           enddo
3888         endif
3889       enddo
3890       return
3891       end
3892 C--------------------------------------------------------------------------
3893       subroutine ssbond_ene(i,j,eij)
3894 C
3895 C Calculate the distance and angle dependent SS-bond potential energy
3896 C using a free-energy function derived based on RHF/6-31G** ab initio
3897 C calculations of diethyl disulfide.
3898 C
3899 C A. Liwo and U. Kozlowska, 11/24/03
3900 C
3901       implicit real*8 (a-h,o-z)
3902       include 'DIMENSIONS'
3903       include 'sizesclu.dat'
3904       include 'COMMON.SBRIDGE'
3905       include 'COMMON.CHAIN'
3906       include 'COMMON.DERIV'
3907       include 'COMMON.LOCAL'
3908       include 'COMMON.INTERACT'
3909       include 'COMMON.VAR'
3910       include 'COMMON.IOUNITS'
3911       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3912       itypi=iabs(itype(i))
3913       xi=c(1,nres+i)
3914       yi=c(2,nres+i)
3915       zi=c(3,nres+i)
3916       dxi=dc_norm(1,nres+i)
3917       dyi=dc_norm(2,nres+i)
3918       dzi=dc_norm(3,nres+i)
3919       dsci_inv=dsc_inv(itypi)
3920       itypj=iabs(itype(j))
3921       dscj_inv=dsc_inv(itypj)
3922       xj=c(1,nres+j)-xi
3923       yj=c(2,nres+j)-yi
3924       zj=c(3,nres+j)-zi
3925       dxj=dc_norm(1,nres+j)
3926       dyj=dc_norm(2,nres+j)
3927       dzj=dc_norm(3,nres+j)
3928       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3929       rij=dsqrt(rrij)
3930       erij(1)=xj*rij
3931       erij(2)=yj*rij
3932       erij(3)=zj*rij
3933       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3934       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3935       om12=dxi*dxj+dyi*dyj+dzi*dzj
3936       do k=1,3
3937         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3938         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3939       enddo
3940       rij=1.0d0/rij
3941       deltad=rij-d0cm
3942       deltat1=1.0d0-om1
3943       deltat2=1.0d0+om2
3944       deltat12=om2-om1+2.0d0
3945       cosphi=om12-om1*om2
3946       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3947      &  +akct*deltad*deltat12
3948      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3949 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3950 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3951 c     &  " deltat12",deltat12," eij",eij
3952       ed=2*akcm*deltad+akct*deltat12
3953       pom1=akct*deltad
3954       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3955       eom1=-2*akth*deltat1-pom1-om2*pom2
3956       eom2= 2*akth*deltat2+pom1-om1*pom2
3957       eom12=pom2
3958       do k=1,3
3959         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3960       enddo
3961       do k=1,3
3962         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3963      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3964         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3965      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3966       enddo
3967 C
3968 C Calculate the components of the gradient in DC and X
3969 C
3970       do k=i,j-1
3971         do l=1,3
3972           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3973         enddo
3974       enddo
3975       return
3976       end
3977 C--------------------------------------------------------------------------
3978
3979
3980 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
3981       subroutine e_modeller(ehomology_constr)
3982       implicit real*8 (a-h,o-z)
3983
3984       include 'DIMENSIONS'
3985
3986       integer nnn, i, j, k, ki, irec, l
3987       integer katy, odleglosci, test7
3988       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3989       real*8 distance(max_template),distancek(max_template),
3990      &    min_odl,godl(max_template),dih_diff(max_template)
3991
3992 c
3993 c     FP - 30/10/2014 Temporary specifications for homology restraints
3994 c
3995       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3996      &                 sgtheta
3997       double precision, dimension (maxres) :: guscdiff,usc_diff
3998       double precision, dimension (max_template) ::
3999      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
4000      &           theta_diff
4001
4002       include 'COMMON.SBRIDGE'
4003       include 'COMMON.CHAIN'
4004       include 'COMMON.GEO'
4005       include 'COMMON.DERIV'
4006       include 'COMMON.LOCAL'
4007       include 'COMMON.INTERACT'
4008       include 'COMMON.VAR'
4009       include 'COMMON.IOUNITS'
4010       include 'COMMON.CONTROL'
4011       include 'COMMON.HOMRESTR'
4012 c
4013       include 'COMMON.SETUP'
4014       include 'COMMON.NAMES'
4015
4016       do i=1,max_template
4017         distancek(i)=9999999.9
4018       enddo
4019
4020       odleg=0.0d0
4021
4022 c Pseudo-energy and gradient from homology restraints (MODELLER-like
4023 c function)
4024 C AL 5/2/14 - Introduce list of restraints
4025 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
4026 #ifdef DEBUG
4027       write(iout,*) "------- dist restrs start -------"
4028       write (iout,*) "link_start_homo",link_start_homo,
4029      &    " link_end_homo",link_end_homo
4030 #endif
4031       do ii = link_start_homo,link_end_homo
4032          i = ires_homo(ii)
4033          j = jres_homo(ii)
4034          dij=dist(i,j)
4035 c        write (iout,*) "dij(",i,j,") =",dij
4036          nexl=0
4037          do k=1,constr_homology
4038            if(.not.l_homo(k,ii)) then
4039               nexl=nexl+1
4040               cycle
4041            endif
4042            distance(k)=odl(k,ii)-dij
4043 c          write (iout,*) "distance(",k,") =",distance(k)
4044 c
4045 c          For Gaussian-type Urestr
4046 c
4047            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4048 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4049 c          write (iout,*) "distancek(",k,") =",distancek(k)
4050 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4051 c
4052 c          For Lorentzian-type Urestr
4053 c
4054            if (waga_dist.lt.0.0d0) then
4055               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4056               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4057      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4058            endif
4059          enddo
4060
4061 c         min_odl=minval(distancek)
4062          do kk=1,constr_homology
4063           if(l_homo(kk,ii)) then
4064             min_odl=distancek(kk)
4065             exit
4066           endif
4067          enddo
4068          do kk=1,constr_homology
4069           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4070      &              min_odl=distancek(kk)
4071          enddo
4072 c        write (iout,* )"min_odl",min_odl
4073 #ifdef DEBUG
4074          write (iout,*) "ij dij",i,j,dij
4075          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4076          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4077          write (iout,* )"min_odl",min_odl
4078 #endif
4079 #ifdef OLDRESTR
4080          odleg2=0.0d0
4081 #else
4082          if (waga_dist.ge.0.0d0) then
4083            odleg2=nexl
4084          else
4085            odleg2=0.0d0
4086          endif
4087 #endif
4088          do k=1,constr_homology
4089 c Nie wiem po co to liczycie jeszcze raz!
4090 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4091 c     &              (2*(sigma_odl(i,j,k))**2))
4092            if(.not.l_homo(k,ii)) cycle
4093            if (waga_dist.ge.0.0d0) then
4094 c
4095 c          For Gaussian-type Urestr
4096 c
4097             godl(k)=dexp(-distancek(k)+min_odl)
4098             odleg2=odleg2+godl(k)
4099 c
4100 c          For Lorentzian-type Urestr
4101 c
4102            else
4103             odleg2=odleg2+distancek(k)
4104            endif
4105
4106 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4107 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4108 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4109 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4110
4111          enddo
4112 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4113 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4114 #ifdef DEBUG
4115          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4116          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4117 #endif
4118            if (waga_dist.ge.0.0d0) then
4119 c
4120 c          For Gaussian-type Urestr
4121 c
4122               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4123 c
4124 c          For Lorentzian-type Urestr
4125 c
4126            else
4127               odleg=odleg+odleg2/constr_homology
4128            endif
4129 c
4130 #ifdef GRAD
4131 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4132 c Gradient
4133 c
4134 c          For Gaussian-type Urestr
4135 c
4136          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4137          sum_sgodl=0.0d0
4138          do k=1,constr_homology
4139 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4140 c     &           *waga_dist)+min_odl
4141 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4142 c
4143          if(.not.l_homo(k,ii)) cycle
4144          if (waga_dist.ge.0.0d0) then
4145 c          For Gaussian-type Urestr
4146 c
4147            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4148 c
4149 c          For Lorentzian-type Urestr
4150 c
4151          else
4152            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4153      &           sigma_odlir(k,ii)**2)**2)
4154          endif
4155            sum_sgodl=sum_sgodl+sgodl
4156
4157 c            sgodl2=sgodl2+sgodl
4158 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4159 c      write(iout,*) "constr_homology=",constr_homology
4160 c      write(iout,*) i, j, k, "TEST K"
4161          enddo
4162          if (waga_dist.ge.0.0d0) then
4163 c
4164 c          For Gaussian-type Urestr
4165 c
4166             grad_odl3=waga_homology(iset)*waga_dist
4167      &                *sum_sgodl/(sum_godl*dij)
4168 c
4169 c          For Lorentzian-type Urestr
4170 c
4171          else
4172 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4173 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4174             grad_odl3=-waga_homology(iset)*waga_dist*
4175      &                sum_sgodl/(constr_homology*dij)
4176          endif
4177 c
4178 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4179
4180
4181 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4182 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4183 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4184
4185 ccc      write(iout,*) godl, sgodl, grad_odl3
4186
4187 c          grad_odl=grad_odl+grad_odl3
4188
4189          do jik=1,3
4190             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4191 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4192 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4193 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4194             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4195             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4196 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4197 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4198 c         if (i.eq.25.and.j.eq.27) then
4199 c         write(iout,*) "jik",jik,"i",i,"j",j
4200 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4201 c         write(iout,*) "grad_odl3",grad_odl3
4202 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4203 c         write(iout,*) "ggodl",ggodl
4204 c         write(iout,*) "ghpbc(",jik,i,")",
4205 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4206 c     &                 ghpbc(jik,j)
4207 c         endif
4208          enddo
4209 #endif
4210 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4211 ccc     & dLOG(odleg2),"-odleg=", -odleg
4212
4213       enddo ! ii-loop for dist
4214 #ifdef DEBUG
4215       write(iout,*) "------- dist restrs end -------"
4216 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4217 c    &     waga_d.eq.1.0d0) call sum_gradient
4218 #endif
4219 c Pseudo-energy and gradient from dihedral-angle restraints from
4220 c homology templates
4221 c      write (iout,*) "End of distance loop"
4222 c      call flush(iout)
4223       kat=0.0d0
4224 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4225 #ifdef DEBUG
4226       write(iout,*) "------- dih restrs start -------"
4227       do i=idihconstr_start_homo,idihconstr_end_homo
4228         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4229       enddo
4230 #endif
4231       do i=idihconstr_start_homo,idihconstr_end_homo
4232         kat2=0.0d0
4233 c        betai=beta(i,i+1,i+2,i+3)
4234         betai = phi(i)
4235 c       write (iout,*) "betai =",betai
4236         do k=1,constr_homology
4237           dih_diff(k)=pinorm(dih(k,i)-betai)
4238 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4239 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4240 c     &                                   -(6.28318-dih_diff(i,k))
4241 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4242 c     &                                   6.28318+dih_diff(i,k)
4243 #ifdef OLD_DIHED
4244           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4245 #else
4246           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
4247 #endif
4248 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4249           gdih(k)=dexp(kat3)
4250           kat2=kat2+gdih(k)
4251 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4252 c          write(*,*)""
4253         enddo
4254 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4255 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4256 #ifdef DEBUG
4257         write (iout,*) "i",i," betai",betai," kat2",kat2
4258         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4259 #endif
4260         if (kat2.le.1.0d-14) cycle
4261         kat=kat-dLOG(kat2/constr_homology)
4262 c       write (iout,*) "kat",kat ! sum of -ln-s
4263
4264 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4265 ccc     & dLOG(kat2), "-kat=", -kat
4266
4267 #ifdef GRAD
4268 c ----------------------------------------------------------------------
4269 c Gradient
4270 c ----------------------------------------------------------------------
4271
4272         sum_gdih=kat2
4273         sum_sgdih=0.0d0
4274         do k=1,constr_homology
4275 #ifdef OLD_DIHED
4276           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4277 #else
4278           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
4279 #endif
4280 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4281           sum_sgdih=sum_sgdih+sgdih
4282         enddo
4283 c       grad_dih3=sum_sgdih/sum_gdih
4284         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4285
4286 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4287 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4288 ccc     & gloc(nphi+i-3,icg)
4289         gloc(i,icg)=gloc(i,icg)+grad_dih3
4290 c        if (i.eq.25) then
4291 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4292 c        endif
4293 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4294 ccc     & gloc(nphi+i-3,icg)
4295 #endif
4296       enddo ! i-loop for dih
4297 #ifdef DEBUG
4298       write(iout,*) "------- dih restrs end -------"
4299 #endif
4300
4301 c Pseudo-energy and gradient for theta angle restraints from
4302 c homology templates
4303 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4304 c adapted
4305
4306 c
4307 c     For constr_homology reference structures (FP)
4308 c
4309 c     Uconst_back_tot=0.0d0
4310       Eval=0.0d0
4311       Erot=0.0d0
4312 c     Econstr_back legacy
4313 #ifdef GRAD
4314       do i=1,nres
4315 c     do i=ithet_start,ithet_end
4316        dutheta(i)=0.0d0
4317 c     enddo
4318 c     do i=loc_start,loc_end
4319         do j=1,3
4320           duscdiff(j,i)=0.0d0
4321           duscdiffx(j,i)=0.0d0
4322         enddo
4323       enddo
4324 #endif
4325 c
4326 c     do iref=1,nref
4327 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4328 c     write (iout,*) "waga_theta",waga_theta
4329       if (waga_theta.gt.0.0d0) then
4330 #ifdef DEBUG
4331       write (iout,*) "usampl",usampl
4332       write(iout,*) "------- theta restrs start -------"
4333 c     do i=ithet_start,ithet_end
4334 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4335 c     enddo
4336 #endif
4337 c     write (iout,*) "maxres",maxres,"nres",nres
4338
4339       do i=ithet_start,ithet_end
4340 c
4341 c     do i=1,nfrag_back
4342 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4343 c
4344 c Deviation of theta angles wrt constr_homology ref structures
4345 c
4346         utheta_i=0.0d0 ! argument of Gaussian for single k
4347         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4348 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4349 c       over residues in a fragment
4350 c       write (iout,*) "theta(",i,")=",theta(i)
4351         do k=1,constr_homology
4352 c
4353 c         dtheta_i=theta(j)-thetaref(j,iref)
4354 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4355           theta_diff(k)=thetatpl(k,i)-theta(i)
4356 c
4357           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4358 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4359           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4360           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4361 c         Gradient for single Gaussian restraint in subr Econstr_back
4362 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4363 c
4364         enddo
4365 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4366 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4367
4368 c
4369 #ifdef GRAD
4370 c         Gradient for multiple Gaussian restraint
4371         sum_gtheta=gutheta_i
4372         sum_sgtheta=0.0d0
4373         do k=1,constr_homology
4374 c        New generalized expr for multiple Gaussian from Econstr_back
4375          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4376 c
4377 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4378           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4379         enddo
4380 c
4381 c       Final value of gradient using same var as in Econstr_back
4382         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4383      &               *waga_homology(iset)
4384 c       dutheta(i)=sum_sgtheta/sum_gtheta
4385 c
4386 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4387 #endif
4388         Eval=Eval-dLOG(gutheta_i/constr_homology)
4389 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4390 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4391 c       Uconst_back=Uconst_back+utheta(i)
4392       enddo ! (i-loop for theta)
4393 #ifdef DEBUG
4394       write(iout,*) "------- theta restrs end -------"
4395 #endif
4396       endif
4397 c
4398 c Deviation of local SC geometry
4399 c
4400 c Separation of two i-loops (instructed by AL - 11/3/2014)
4401 c
4402 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4403 c     write (iout,*) "waga_d",waga_d
4404
4405 #ifdef DEBUG
4406       write(iout,*) "------- SC restrs start -------"
4407       write (iout,*) "Initial duscdiff,duscdiffx"
4408       do i=loc_start,loc_end
4409         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4410      &                 (duscdiffx(jik,i),jik=1,3)
4411       enddo
4412 #endif
4413       do i=loc_start,loc_end
4414         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4415         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4416 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4417 c       write(iout,*) "xxtab, yytab, zztab"
4418 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4419         do k=1,constr_homology
4420 c
4421           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4422 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4423           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4424           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4425 c         write(iout,*) "dxx, dyy, dzz"
4426 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4427 c
4428           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4429 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4430 c         uscdiffk(k)=usc_diff(i)
4431           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4432           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4433 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4434 c     &      xxref(j),yyref(j),zzref(j)
4435         enddo
4436 c
4437 c       Gradient
4438 c
4439 c       Generalized expression for multiple Gaussian acc to that for a single
4440 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4441 c
4442 c       Original implementation
4443 c       sum_guscdiff=guscdiff(i)
4444 c
4445 c       sum_sguscdiff=0.0d0
4446 c       do k=1,constr_homology
4447 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4448 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4449 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
4450 c       enddo
4451 c
4452 c       Implementation of new expressions for gradient (Jan. 2015)
4453 c
4454 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
4455 #ifdef GRAD
4456         do k=1,constr_homology
4457 c
4458 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
4459 c       before. Now the drivatives should be correct
4460 c
4461           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4462 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
4463           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4464           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4465 c
4466 c         New implementation
4467 c
4468           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
4469      &                 sigma_d(k,i) ! for the grad wrt r'
4470 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
4471 c
4472 c
4473 c        New implementation
4474          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
4475          do jik=1,3
4476             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
4477      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
4478      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
4479             duscdiff(jik,i)=duscdiff(jik,i)+
4480      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
4481      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
4482             duscdiffx(jik,i)=duscdiffx(jik,i)+
4483      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
4484      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
4485 c
4486 #ifdef DEBUG
4487              write(iout,*) "jik",jik,"i",i
4488              write(iout,*) "dxx, dyy, dzz"
4489              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4490              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
4491 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
4492 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
4493 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
4494 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
4495 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
4496 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
4497 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
4498 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
4499 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
4500 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
4501 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
4502 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
4503 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
4504 c            endif
4505 #endif
4506          enddo
4507         enddo
4508 #endif
4509 c
4510 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
4511 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
4512 c
4513 c        write (iout,*) i," uscdiff",uscdiff(i)
4514 c
4515 c Put together deviations from local geometry
4516
4517 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
4518 c      &            wfrag_back(3,i,iset)*uscdiff(i)
4519         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
4520 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
4521 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
4522 c       Uconst_back=Uconst_back+usc_diff(i)
4523 c
4524 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
4525 c
4526 c     New implment: multiplied by sum_sguscdiff
4527 c
4528
4529       enddo ! (i-loop for dscdiff)
4530
4531 c      endif
4532
4533 #ifdef DEBUG
4534       write(iout,*) "------- SC restrs end -------"
4535         write (iout,*) "------ After SC loop in e_modeller ------"
4536         do i=loc_start,loc_end
4537          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
4538          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
4539         enddo
4540       if (waga_theta.eq.1.0d0) then
4541       write (iout,*) "in e_modeller after SC restr end: dutheta"
4542       do i=ithet_start,ithet_end
4543         write (iout,*) i,dutheta(i)
4544       enddo
4545       endif
4546       if (waga_d.eq.1.0d0) then
4547       write (iout,*) "e_modeller after SC loop: duscdiff/x"
4548       do i=1,nres
4549         write (iout,*) i,(duscdiff(j,i),j=1,3)
4550         write (iout,*) i,(duscdiffx(j,i),j=1,3)
4551       enddo
4552       endif
4553 #endif
4554
4555 c Total energy from homology restraints
4556 #ifdef DEBUG
4557       write (iout,*) "odleg",odleg," kat",kat
4558       write (iout,*) "odleg",odleg," kat",kat
4559       write (iout,*) "Eval",Eval," Erot",Erot
4560       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4561       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
4562       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
4563       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4564 #endif
4565 c
4566 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
4567 c
4568 c     ehomology_constr=odleg+kat
4569 c
4570 c     For Lorentzian-type Urestr
4571 c
4572
4573       if (waga_dist.ge.0.0d0) then
4574 c
4575 c          For Gaussian-type Urestr
4576 c
4577         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4578      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4579 c     write (iout,*) "ehomology_constr=",ehomology_constr
4580       else
4581 c
4582 c          For Lorentzian-type Urestr
4583 c
4584         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4585      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4586 c     write (iout,*) "ehomology_constr=",ehomology_constr
4587       endif
4588 #ifdef DEBUG
4589       write (iout,*) "iset",iset," waga_homology",waga_homology(iset)
4590       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4591      & " Eval",waga_theta,Eval," Erot",waga_d,Erot
4592       write (iout,*) "ehomology_constr",ehomology_constr
4593 #endif
4594       return
4595
4596   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4597   747 format(a12,i4,i4,i4,f8.3,f8.3)
4598   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4599   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4600   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4601      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4602       end
4603 C--------------------------------------------------------------------------
4604
4605 C--------------------------------------------------------------------------
4606       subroutine ebond(estr)
4607 c
4608 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4609 c
4610       implicit real*8 (a-h,o-z)
4611       include 'DIMENSIONS'
4612       include 'sizesclu.dat'
4613       include 'COMMON.LOCAL'
4614       include 'COMMON.GEO'
4615       include 'COMMON.INTERACT'
4616       include 'COMMON.DERIV'
4617       include 'COMMON.VAR'
4618       include 'COMMON.CHAIN'
4619       include 'COMMON.IOUNITS'
4620       include 'COMMON.NAMES'
4621       include 'COMMON.FFIELD'
4622       include 'COMMON.CONTROL'
4623       double precision u(3),ud(3)
4624       estr=0.0d0
4625       estr1=0.0d0
4626       do i=nnt+1,nct
4627         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4628 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4629 C          do j=1,3
4630 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4631 C     &      *dc(j,i-1)/vbld(i)
4632 C          enddo
4633 C          if (energy_dec) write(iout,*)
4634 C     &       "estr1",i,vbld(i),distchainmax,
4635 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4636 C        else
4637          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4638         diff = vbld(i)-vbldpDUM
4639          else
4640           diff = vbld(i)-vbldp0
4641 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4642          endif
4643           estr=estr+diff*diff
4644           do j=1,3
4645             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4646           enddo
4647 C        endif
4648 C        write (iout,'(a7,i5,4f7.3)')
4649 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4650       enddo
4651       estr=0.5d0*AKP*estr+estr1
4652 c
4653 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4654 c
4655       do i=nnt,nct
4656         iti=iabs(itype(i))
4657         if (iti.ne.10 .and. iti.ne.ntyp1) then
4658           nbi=nbondterm(iti)
4659           if (nbi.eq.1) then
4660             diff=vbld(i+nres)-vbldsc0(1,iti)
4661 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4662 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4663             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4664             do j=1,3
4665               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4666             enddo
4667           else
4668             do j=1,nbi
4669               diff=vbld(i+nres)-vbldsc0(j,iti)
4670               ud(j)=aksc(j,iti)*diff
4671               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4672             enddo
4673             uprod=u(1)
4674             do j=2,nbi
4675               uprod=uprod*u(j)
4676             enddo
4677             usum=0.0d0
4678             usumsqder=0.0d0
4679             do j=1,nbi
4680               uprod1=1.0d0
4681               uprod2=1.0d0
4682               do k=1,nbi
4683                 if (k.ne.j) then
4684                   uprod1=uprod1*u(k)
4685                   uprod2=uprod2*u(k)*u(k)
4686                 endif
4687               enddo
4688               usum=usum+uprod1
4689               usumsqder=usumsqder+ud(j)*uprod2
4690             enddo
4691 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4692 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4693             estr=estr+uprod/usum
4694             do j=1,3
4695              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4696             enddo
4697           endif
4698         endif
4699       enddo
4700       return
4701       end
4702 #ifdef CRYST_THETA
4703 C--------------------------------------------------------------------------
4704       subroutine ebend(etheta,ethetacnstr)
4705 C
4706 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4707 C angles gamma and its derivatives in consecutive thetas and gammas.
4708 C
4709       implicit real*8 (a-h,o-z)
4710       include 'DIMENSIONS'
4711       include 'sizesclu.dat'
4712       include 'COMMON.LOCAL'
4713       include 'COMMON.GEO'
4714       include 'COMMON.INTERACT'
4715       include 'COMMON.DERIV'
4716       include 'COMMON.VAR'
4717       include 'COMMON.CHAIN'
4718       include 'COMMON.IOUNITS'
4719       include 'COMMON.NAMES'
4720       include 'COMMON.FFIELD'
4721       include 'COMMON.TORCNSTR'
4722       common /calcthet/ term1,term2,termm,diffak,ratak,
4723      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4724      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4725       double precision y(2),z(2)
4726       delta=0.02d0*pi
4727 c      time11=dexp(-2*time)
4728 c      time12=1.0d0
4729       etheta=0.0D0
4730 c      write (iout,*) "nres",nres
4731 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4732 c      write (iout,*) ithet_start,ithet_end
4733       do i=ithet_start,ithet_end
4734 C        if (itype(i-1).eq.ntyp1) cycle
4735 c        if (i.le.2) cycle
4736         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4737      &  .or.itype(i).eq.ntyp1) cycle
4738 C Zero the energy function and its derivative at 0 or pi.
4739         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4740         it=itype(i-1)
4741         ichir1=isign(1,itype(i-2))
4742         ichir2=isign(1,itype(i))
4743          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4744          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4745          if (itype(i-1).eq.10) then
4746           itype1=isign(10,itype(i-2))
4747           ichir11=isign(1,itype(i-2))
4748           ichir12=isign(1,itype(i-2))
4749           itype2=isign(10,itype(i))
4750           ichir21=isign(1,itype(i))
4751           ichir22=isign(1,itype(i))
4752          endif
4753          if (i.eq.3) then
4754           y(1)=0.0D0
4755           y(2)=0.0D0
4756           else
4757
4758         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4759 #ifdef OSF
4760           phii=phi(i)
4761 c          icrc=0
4762 c          call proc_proc(phii,icrc)
4763           if (icrc.eq.1) phii=150.0
4764 #else
4765           phii=phi(i)
4766 #endif
4767           y(1)=dcos(phii)
4768           y(2)=dsin(phii)
4769         else
4770           y(1)=0.0D0
4771           y(2)=0.0D0
4772         endif
4773         endif
4774         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4775 #ifdef OSF
4776           phii1=phi(i+1)
4777 c          icrc=0
4778 c          call proc_proc(phii1,icrc)
4779           if (icrc.eq.1) phii1=150.0
4780           phii1=pinorm(phii1)
4781           z(1)=cos(phii1)
4782 #else
4783           phii1=phi(i+1)
4784           z(1)=dcos(phii1)
4785 #endif
4786           z(2)=dsin(phii1)
4787         else
4788           z(1)=0.0D0
4789           z(2)=0.0D0
4790         endif
4791 C Calculate the "mean" value of theta from the part of the distribution
4792 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4793 C In following comments this theta will be referred to as t_c.
4794         thet_pred_mean=0.0d0
4795         do k=1,2
4796             athetk=athet(k,it,ichir1,ichir2)
4797             bthetk=bthet(k,it,ichir1,ichir2)
4798           if (it.eq.10) then
4799              athetk=athet(k,itype1,ichir11,ichir12)
4800              bthetk=bthet(k,itype2,ichir21,ichir22)
4801           endif
4802           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4803         enddo
4804 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4805         dthett=thet_pred_mean*ssd
4806         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4807 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4808 C Derivatives of the "mean" values in gamma1 and gamma2.
4809         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4810      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4811          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4812      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4813          if (it.eq.10) then
4814       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4815      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4816         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4817      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4818          endif
4819         if (theta(i).gt.pi-delta) then
4820           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4821      &         E_tc0)
4822           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4823           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4824           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4825      &        E_theta)
4826           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4827      &        E_tc)
4828         else if (theta(i).lt.delta) then
4829           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4830           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4831           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4832      &        E_theta)
4833           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4834           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4835      &        E_tc)
4836         else
4837           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4838      &        E_theta,E_tc)
4839         endif
4840         etheta=etheta+ethetai
4841 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4842 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4843         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4844         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4845         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4846 c 1215   continue
4847       enddo
4848 C Ufff.... We've done all this!!!
4849 C now constrains
4850       ethetacnstr=0.0d0
4851 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4852       do i=1,ntheta_constr
4853         itheta=itheta_constr(i)
4854         thetiii=theta(itheta)
4855         difi=pinorm(thetiii-theta_constr0(i))
4856         if (difi.gt.theta_drange(i)) then
4857           difi=difi-theta_drange(i)
4858           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4859           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4860      &    +for_thet_constr(i)*difi**3
4861         else if (difi.lt.-drange(i)) then
4862           difi=difi+drange(i)
4863           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4864           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4865      &    +for_thet_constr(i)*difi**3
4866         else
4867           difi=0.0
4868         endif
4869 C       if (energy_dec) then
4870 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4871 C     &    i,itheta,rad2deg*thetiii,
4872 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4873 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4874 C     &    gloc(itheta+nphi-2,icg)
4875 C        endif
4876       enddo
4877       return
4878       end
4879 C---------------------------------------------------------------------------
4880       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4881      &     E_tc)
4882       implicit real*8 (a-h,o-z)
4883       include 'DIMENSIONS'
4884       include 'COMMON.LOCAL'
4885       include 'COMMON.IOUNITS'
4886       common /calcthet/ term1,term2,termm,diffak,ratak,
4887      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4888      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4889 C Calculate the contributions to both Gaussian lobes.
4890 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4891 C The "polynomial part" of the "standard deviation" of this part of
4892 C the distribution.
4893         sig=polthet(3,it)
4894         do j=2,0,-1
4895           sig=sig*thet_pred_mean+polthet(j,it)
4896         enddo
4897 C Derivative of the "interior part" of the "standard deviation of the"
4898 C gamma-dependent Gaussian lobe in t_c.
4899         sigtc=3*polthet(3,it)
4900         do j=2,1,-1
4901           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4902         enddo
4903         sigtc=sig*sigtc
4904 C Set the parameters of both Gaussian lobes of the distribution.
4905 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4906         fac=sig*sig+sigc0(it)
4907         sigcsq=fac+fac
4908         sigc=1.0D0/sigcsq
4909 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4910         sigsqtc=-4.0D0*sigcsq*sigtc
4911 c       print *,i,sig,sigtc,sigsqtc
4912 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4913         sigtc=-sigtc/(fac*fac)
4914 C Following variable is sigma(t_c)**(-2)
4915         sigcsq=sigcsq*sigcsq
4916         sig0i=sig0(it)
4917         sig0inv=1.0D0/sig0i**2
4918         delthec=thetai-thet_pred_mean
4919         delthe0=thetai-theta0i
4920         term1=-0.5D0*sigcsq*delthec*delthec
4921         term2=-0.5D0*sig0inv*delthe0*delthe0
4922 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4923 C NaNs in taking the logarithm. We extract the largest exponent which is added
4924 C to the energy (this being the log of the distribution) at the end of energy
4925 C term evaluation for this virtual-bond angle.
4926         if (term1.gt.term2) then
4927           termm=term1
4928           term2=dexp(term2-termm)
4929           term1=1.0d0
4930         else
4931           termm=term2
4932           term1=dexp(term1-termm)
4933           term2=1.0d0
4934         endif
4935 C The ratio between the gamma-independent and gamma-dependent lobes of
4936 C the distribution is a Gaussian function of thet_pred_mean too.
4937         diffak=gthet(2,it)-thet_pred_mean
4938         ratak=diffak/gthet(3,it)**2
4939         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4940 C Let's differentiate it in thet_pred_mean NOW.
4941         aktc=ak*ratak
4942 C Now put together the distribution terms to make complete distribution.
4943         termexp=term1+ak*term2
4944         termpre=sigc+ak*sig0i
4945 C Contribution of the bending energy from this theta is just the -log of
4946 C the sum of the contributions from the two lobes and the pre-exponential
4947 C factor. Simple enough, isn't it?
4948         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4949 C NOW the derivatives!!!
4950 C 6/6/97 Take into account the deformation.
4951         E_theta=(delthec*sigcsq*term1
4952      &       +ak*delthe0*sig0inv*term2)/termexp
4953         E_tc=((sigtc+aktc*sig0i)/termpre
4954      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4955      &       aktc*term2)/termexp)
4956       return
4957       end
4958 c-----------------------------------------------------------------------------
4959       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4960       implicit real*8 (a-h,o-z)
4961       include 'DIMENSIONS'
4962       include 'COMMON.LOCAL'
4963       include 'COMMON.IOUNITS'
4964       common /calcthet/ term1,term2,termm,diffak,ratak,
4965      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4966      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4967       delthec=thetai-thet_pred_mean
4968       delthe0=thetai-theta0i
4969 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4970       t3 = thetai-thet_pred_mean
4971       t6 = t3**2
4972       t9 = term1
4973       t12 = t3*sigcsq
4974       t14 = t12+t6*sigsqtc
4975       t16 = 1.0d0
4976       t21 = thetai-theta0i
4977       t23 = t21**2
4978       t26 = term2
4979       t27 = t21*t26
4980       t32 = termexp
4981       t40 = t32**2
4982       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4983      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4984      & *(-t12*t9-ak*sig0inv*t27)
4985       return
4986       end
4987 #else
4988 C--------------------------------------------------------------------------
4989       subroutine ebend(etheta,ethetacnstr)
4990 C
4991 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4992 C angles gamma and its derivatives in consecutive thetas and gammas.
4993 C ab initio-derived potentials from
4994 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4995 C
4996       implicit real*8 (a-h,o-z)
4997       include 'DIMENSIONS'
4998       include 'sizesclu.dat'
4999       include 'COMMON.LOCAL'
5000       include 'COMMON.GEO'
5001       include 'COMMON.INTERACT'
5002       include 'COMMON.DERIV'
5003       include 'COMMON.VAR'
5004       include 'COMMON.CHAIN'
5005       include 'COMMON.IOUNITS'
5006       include 'COMMON.NAMES'
5007       include 'COMMON.FFIELD'
5008       include 'COMMON.CONTROL'
5009       include 'COMMON.TORCNSTR'
5010       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5011      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5012      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5013      & sinph1ph2(maxdouble,maxdouble)
5014       logical lprn /.false./, lprn1 /.false./
5015       etheta=0.0D0
5016 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5017       do i=ithet_start,ithet_end
5018 c        if (i.eq.2) cycle
5019 c        print *,i,itype(i-1),itype(i),itype(i-2)
5020         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
5021      &  .or.(itype(i).eq.ntyp1)) cycle
5022 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5023
5024         if (iabs(itype(i+1)).eq.20) iblock=2
5025         if (iabs(itype(i+1)).ne.20) iblock=1
5026         dethetai=0.0d0
5027         dephii=0.0d0
5028         dephii1=0.0d0
5029         theti2=0.5d0*theta(i)
5030         ityp2=ithetyp((itype(i-1)))
5031         do k=1,nntheterm
5032           coskt(k)=dcos(k*theti2)
5033           sinkt(k)=dsin(k*theti2)
5034         enddo
5035         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5036 #ifdef OSF
5037           phii=phi(i)
5038           if (phii.ne.phii) phii=150.0
5039 #else
5040           phii=phi(i)
5041 #endif
5042           ityp1=ithetyp((itype(i-2)))
5043           do k=1,nsingle
5044             cosph1(k)=dcos(k*phii)
5045             sinph1(k)=dsin(k*phii)
5046           enddo
5047         else
5048           phii=0.0d0
5049           ityp1=ithetyp(itype(i-2))
5050           do k=1,nsingle
5051             cosph1(k)=0.0d0
5052             sinph1(k)=0.0d0
5053           enddo
5054         endif
5055         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5056 #ifdef OSF
5057           phii1=phi(i+1)
5058           if (phii1.ne.phii1) phii1=150.0
5059           phii1=pinorm(phii1)
5060 #else
5061           phii1=phi(i+1)
5062 #endif
5063           ityp3=ithetyp((itype(i)))
5064           do k=1,nsingle
5065             cosph2(k)=dcos(k*phii1)
5066             sinph2(k)=dsin(k*phii1)
5067           enddo
5068         else
5069           phii1=0.0d0
5070           ityp3=ithetyp(itype(i))
5071           do k=1,nsingle
5072             cosph2(k)=0.0d0
5073             sinph2(k)=0.0d0
5074           enddo
5075         endif
5076 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5077 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5078 c        call flush(iout)
5079         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5080         do k=1,ndouble
5081           do l=1,k-1
5082             ccl=cosph1(l)*cosph2(k-l)
5083             ssl=sinph1(l)*sinph2(k-l)
5084             scl=sinph1(l)*cosph2(k-l)
5085             csl=cosph1(l)*sinph2(k-l)
5086             cosph1ph2(l,k)=ccl-ssl
5087             cosph1ph2(k,l)=ccl+ssl
5088             sinph1ph2(l,k)=scl+csl
5089             sinph1ph2(k,l)=scl-csl
5090           enddo
5091         enddo
5092         if (lprn) then
5093         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5094      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5095         write (iout,*) "coskt and sinkt"
5096         do k=1,nntheterm
5097           write (iout,*) k,coskt(k),sinkt(k)
5098         enddo
5099         endif
5100         do k=1,ntheterm
5101           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5102           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5103      &      *coskt(k)
5104           if (lprn)
5105      &    write (iout,*) "k",k," aathet",
5106      &    aathet(k,ityp1,ityp2,ityp3,iblock),
5107      &     " ethetai",ethetai
5108         enddo
5109         if (lprn) then
5110         write (iout,*) "cosph and sinph"
5111         do k=1,nsingle
5112           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5113         enddo
5114         write (iout,*) "cosph1ph2 and sinph2ph2"
5115         do k=2,ndouble
5116           do l=1,k-1
5117             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5118      &         sinph1ph2(l,k),sinph1ph2(k,l)
5119           enddo
5120         enddo
5121         write(iout,*) "ethetai",ethetai
5122         endif
5123         do m=1,ntheterm2
5124           do k=1,nsingle
5125             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5126      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5127      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5128      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5129             ethetai=ethetai+sinkt(m)*aux
5130             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5131             dephii=dephii+k*sinkt(m)*(
5132      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5133      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5134             dephii1=dephii1+k*sinkt(m)*(
5135      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5136      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5137             if (lprn)
5138      &      write (iout,*) "m",m," k",k," bbthet",
5139      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5140      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5141      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5142      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5143           enddo
5144         enddo
5145         if (lprn)
5146      &  write(iout,*) "ethetai",ethetai
5147         do m=1,ntheterm3
5148           do k=2,ndouble
5149             do l=1,k-1
5150               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5151      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5152      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5153      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5154               ethetai=ethetai+sinkt(m)*aux
5155               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5156               dephii=dephii+l*sinkt(m)*(
5157      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5158      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5159      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5160      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5161               dephii1=dephii1+(k-l)*sinkt(m)*(
5162      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5163      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5164      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5165      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5166               if (lprn) then
5167               write (iout,*) "m",m," k",k," l",l," ffthet",
5168      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5169      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5170      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5171      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5172      &            " ethetai",ethetai
5173               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5174      &            cosph1ph2(k,l)*sinkt(m),
5175      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5176               endif
5177             enddo
5178           enddo
5179         enddo
5180 10      continue
5181         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5182      &   i,theta(i)*rad2deg,phii*rad2deg,
5183      &   phii1*rad2deg,ethetai
5184         etheta=etheta+ethetai
5185         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5186         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5187 c        gloc(nphi+i-2,icg)=wang*dethetai
5188         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5189       enddo
5190 C now constrains
5191       ethetacnstr=0.0d0
5192 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5193       do i=1,ntheta_constr
5194         itheta=itheta_constr(i)
5195         thetiii=theta(itheta)
5196         difi=pinorm(thetiii-theta_constr0(i))
5197         if (difi.gt.theta_drange(i)) then
5198           difi=difi-theta_drange(i)
5199           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5200           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5201      &    +for_thet_constr(i)*difi**3
5202         else if (difi.lt.-drange(i)) then
5203           difi=difi+drange(i)
5204           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5205           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5206      &    +for_thet_constr(i)*difi**3
5207         else
5208           difi=0.0
5209         endif
5210 C       if (energy_dec) then
5211 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5212 C     &    i,itheta,rad2deg*thetiii,
5213 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5214 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5215 C     &    gloc(itheta+nphi-2,icg)
5216 C        endif
5217       enddo
5218       return
5219       end
5220 #endif
5221 #ifdef CRYST_SC
5222 c-----------------------------------------------------------------------------
5223       subroutine esc(escloc)
5224 C Calculate the local energy of a side chain and its derivatives in the
5225 C corresponding virtual-bond valence angles THETA and the spherical angles
5226 C ALPHA and OMEGA.
5227       implicit real*8 (a-h,o-z)
5228       include 'DIMENSIONS'
5229       include 'sizesclu.dat'
5230       include 'COMMON.GEO'
5231       include 'COMMON.LOCAL'
5232       include 'COMMON.VAR'
5233       include 'COMMON.INTERACT'
5234       include 'COMMON.DERIV'
5235       include 'COMMON.CHAIN'
5236       include 'COMMON.IOUNITS'
5237       include 'COMMON.NAMES'
5238       include 'COMMON.FFIELD'
5239       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5240      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5241       common /sccalc/ time11,time12,time112,theti,it,nlobit
5242       delta=0.02d0*pi
5243       escloc=0.0D0
5244 c     write (iout,'(a)') 'ESC'
5245       do i=loc_start,loc_end
5246         it=itype(i)
5247         if (it.eq.ntyp1) cycle
5248         if (it.eq.10) goto 1
5249         nlobit=nlob(iabs(it))
5250 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5251 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5252         theti=theta(i+1)-pipol
5253         x(1)=dtan(theti)
5254         x(2)=alph(i)
5255         x(3)=omeg(i)
5256 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5257
5258         if (x(2).gt.pi-delta) then
5259           xtemp(1)=x(1)
5260           xtemp(2)=pi-delta
5261           xtemp(3)=x(3)
5262           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5263           xtemp(2)=pi
5264           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5265           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5266      &        escloci,dersc(2))
5267           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5268      &        ddersc0(1),dersc(1))
5269           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5270      &        ddersc0(3),dersc(3))
5271           xtemp(2)=pi-delta
5272           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5273           xtemp(2)=pi
5274           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5275           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5276      &            dersc0(2),esclocbi,dersc02)
5277           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5278      &            dersc12,dersc01)
5279           call splinthet(x(2),0.5d0*delta,ss,ssd)
5280           dersc0(1)=dersc01
5281           dersc0(2)=dersc02
5282           dersc0(3)=0.0d0
5283           do k=1,3
5284             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5285           enddo
5286           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5287 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5288 c    &             esclocbi,ss,ssd
5289           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5290 c         escloci=esclocbi
5291 c         write (iout,*) escloci
5292         else if (x(2).lt.delta) then
5293           xtemp(1)=x(1)
5294           xtemp(2)=delta
5295           xtemp(3)=x(3)
5296           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5297           xtemp(2)=0.0d0
5298           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5299           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5300      &        escloci,dersc(2))
5301           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5302      &        ddersc0(1),dersc(1))
5303           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5304      &        ddersc0(3),dersc(3))
5305           xtemp(2)=delta
5306           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5307           xtemp(2)=0.0d0
5308           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5309           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5310      &            dersc0(2),esclocbi,dersc02)
5311           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5312      &            dersc12,dersc01)
5313           dersc0(1)=dersc01
5314           dersc0(2)=dersc02
5315           dersc0(3)=0.0d0
5316           call splinthet(x(2),0.5d0*delta,ss,ssd)
5317           do k=1,3
5318             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5319           enddo
5320           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5321 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5322 c    &             esclocbi,ss,ssd
5323           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5324 c         write (iout,*) escloci
5325         else
5326           call enesc(x,escloci,dersc,ddummy,.false.)
5327         endif
5328
5329         escloc=escloc+escloci
5330 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5331
5332         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5333      &   wscloc*dersc(1)
5334         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5335         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5336     1   continue
5337       enddo
5338       return
5339       end
5340 C---------------------------------------------------------------------------
5341       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5342       implicit real*8 (a-h,o-z)
5343       include 'DIMENSIONS'
5344       include 'COMMON.GEO'
5345       include 'COMMON.LOCAL'
5346       include 'COMMON.IOUNITS'
5347       common /sccalc/ time11,time12,time112,theti,it,nlobit
5348       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5349       double precision contr(maxlob,-1:1)
5350       logical mixed
5351 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5352         escloc_i=0.0D0
5353         do j=1,3
5354           dersc(j)=0.0D0
5355           if (mixed) ddersc(j)=0.0d0
5356         enddo
5357         x3=x(3)
5358
5359 C Because of periodicity of the dependence of the SC energy in omega we have
5360 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5361 C To avoid underflows, first compute & store the exponents.
5362
5363         do iii=-1,1
5364
5365           x(3)=x3+iii*dwapi
5366
5367           do j=1,nlobit
5368             do k=1,3
5369               z(k)=x(k)-censc(k,j,it)
5370             enddo
5371             do k=1,3
5372               Axk=0.0D0
5373               do l=1,3
5374                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5375               enddo
5376               Ax(k,j,iii)=Axk
5377             enddo
5378             expfac=0.0D0
5379             do k=1,3
5380               expfac=expfac+Ax(k,j,iii)*z(k)
5381             enddo
5382             contr(j,iii)=expfac
5383           enddo ! j
5384
5385         enddo ! iii
5386
5387         x(3)=x3
5388 C As in the case of ebend, we want to avoid underflows in exponentiation and
5389 C subsequent NaNs and INFs in energy calculation.
5390 C Find the largest exponent
5391         emin=contr(1,-1)
5392         do iii=-1,1
5393           do j=1,nlobit
5394             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5395           enddo
5396         enddo
5397         emin=0.5D0*emin
5398 cd      print *,'it=',it,' emin=',emin
5399
5400 C Compute the contribution to SC energy and derivatives
5401         do iii=-1,1
5402
5403           do j=1,nlobit
5404             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5405 cd          print *,'j=',j,' expfac=',expfac
5406             escloc_i=escloc_i+expfac
5407             do k=1,3
5408               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5409             enddo
5410             if (mixed) then
5411               do k=1,3,2
5412                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5413      &            +gaussc(k,2,j,it))*expfac
5414               enddo
5415             endif
5416           enddo
5417
5418         enddo ! iii
5419
5420         dersc(1)=dersc(1)/cos(theti)**2
5421         ddersc(1)=ddersc(1)/cos(theti)**2
5422         ddersc(3)=ddersc(3)
5423
5424         escloci=-(dlog(escloc_i)-emin)
5425         do j=1,3
5426           dersc(j)=dersc(j)/escloc_i
5427         enddo
5428         if (mixed) then
5429           do j=1,3,2
5430             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5431           enddo
5432         endif
5433       return
5434       end
5435 C------------------------------------------------------------------------------
5436       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5437       implicit real*8 (a-h,o-z)
5438       include 'DIMENSIONS'
5439       include 'COMMON.GEO'
5440       include 'COMMON.LOCAL'
5441       include 'COMMON.IOUNITS'
5442       common /sccalc/ time11,time12,time112,theti,it,nlobit
5443       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5444       double precision contr(maxlob)
5445       logical mixed
5446
5447       escloc_i=0.0D0
5448
5449       do j=1,3
5450         dersc(j)=0.0D0
5451       enddo
5452
5453       do j=1,nlobit
5454         do k=1,2
5455           z(k)=x(k)-censc(k,j,it)
5456         enddo
5457         z(3)=dwapi
5458         do k=1,3
5459           Axk=0.0D0
5460           do l=1,3
5461             Axk=Axk+gaussc(l,k,j,it)*z(l)
5462           enddo
5463           Ax(k,j)=Axk
5464         enddo
5465         expfac=0.0D0
5466         do k=1,3
5467           expfac=expfac+Ax(k,j)*z(k)
5468         enddo
5469         contr(j)=expfac
5470       enddo ! j
5471
5472 C As in the case of ebend, we want to avoid underflows in exponentiation and
5473 C subsequent NaNs and INFs in energy calculation.
5474 C Find the largest exponent
5475       emin=contr(1)
5476       do j=1,nlobit
5477         if (emin.gt.contr(j)) emin=contr(j)
5478       enddo
5479       emin=0.5D0*emin
5480
5481 C Compute the contribution to SC energy and derivatives
5482
5483       dersc12=0.0d0
5484       do j=1,nlobit
5485         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5486         escloc_i=escloc_i+expfac
5487         do k=1,2
5488           dersc(k)=dersc(k)+Ax(k,j)*expfac
5489         enddo
5490         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5491      &            +gaussc(1,2,j,it))*expfac
5492         dersc(3)=0.0d0
5493       enddo
5494
5495       dersc(1)=dersc(1)/cos(theti)**2
5496       dersc12=dersc12/cos(theti)**2
5497       escloci=-(dlog(escloc_i)-emin)
5498       do j=1,2
5499         dersc(j)=dersc(j)/escloc_i
5500       enddo
5501       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5502       return
5503       end
5504 #else
5505 c----------------------------------------------------------------------------------
5506       subroutine esc(escloc)
5507 C Calculate the local energy of a side chain and its derivatives in the
5508 C corresponding virtual-bond valence angles THETA and the spherical angles
5509 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5510 C added by Urszula Kozlowska. 07/11/2007
5511 C
5512       implicit real*8 (a-h,o-z)
5513       include 'DIMENSIONS'
5514       include 'sizesclu.dat'
5515       include 'COMMON.GEO'
5516       include 'COMMON.LOCAL'
5517       include 'COMMON.VAR'
5518       include 'COMMON.SCROT'
5519       include 'COMMON.INTERACT'
5520       include 'COMMON.DERIV'
5521       include 'COMMON.CHAIN'
5522       include 'COMMON.IOUNITS'
5523       include 'COMMON.NAMES'
5524       include 'COMMON.FFIELD'
5525       include 'COMMON.CONTROL'
5526       include 'COMMON.VECTORS'
5527       double precision x_prime(3),y_prime(3),z_prime(3)
5528      &    , sumene,dsc_i,dp2_i,x(65),
5529      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5530      &    de_dxx,de_dyy,de_dzz,de_dt
5531       double precision s1_t,s1_6_t,s2_t,s2_6_t
5532       double precision
5533      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5534      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5535      & dt_dCi(3),dt_dCi1(3)
5536       common /sccalc/ time11,time12,time112,theti,it,nlobit
5537       delta=0.02d0*pi
5538       escloc=0.0D0
5539       do i=loc_start,loc_end
5540         if (itype(i).eq.ntyp1) cycle
5541         costtab(i+1) =dcos(theta(i+1))
5542         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5543         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5544         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5545         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5546         cosfac=dsqrt(cosfac2)
5547         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5548         sinfac=dsqrt(sinfac2)
5549         it=iabs(itype(i))
5550         if (it.eq.10) goto 1
5551 c
5552 C  Compute the axes of tghe local cartesian coordinates system; store in
5553 c   x_prime, y_prime and z_prime
5554 c
5555         do j=1,3
5556           x_prime(j) = 0.00
5557           y_prime(j) = 0.00
5558           z_prime(j) = 0.00
5559         enddo
5560 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5561 C     &   dc_norm(3,i+nres)
5562         do j = 1,3
5563           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5564           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5565         enddo
5566         do j = 1,3
5567           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5568         enddo
5569 c       write (2,*) "i",i
5570 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5571 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5572 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5573 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5574 c      & " xy",scalar(x_prime(1),y_prime(1)),
5575 c      & " xz",scalar(x_prime(1),z_prime(1)),
5576 c      & " yy",scalar(y_prime(1),y_prime(1)),
5577 c      & " yz",scalar(y_prime(1),z_prime(1)),
5578 c      & " zz",scalar(z_prime(1),z_prime(1))
5579 c
5580 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5581 C to local coordinate system. Store in xx, yy, zz.
5582 c
5583         xx=0.0d0
5584         yy=0.0d0
5585         zz=0.0d0
5586         do j = 1,3
5587           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5588           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5589           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5590         enddo
5591
5592         xxtab(i)=xx
5593         yytab(i)=yy
5594         zztab(i)=zz
5595 C
5596 C Compute the energy of the ith side cbain
5597 C
5598 c        write (2,*) "xx",xx," yy",yy," zz",zz
5599         it=iabs(itype(i))
5600         do j = 1,65
5601           x(j) = sc_parmin(j,it)
5602         enddo
5603 #ifdef CHECK_COORD
5604 Cc diagnostics - remove later
5605         xx1 = dcos(alph(2))
5606         yy1 = dsin(alph(2))*dcos(omeg(2))
5607 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
5608         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5609         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5610      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5611      &    xx1,yy1,zz1
5612 C,"  --- ", xx_w,yy_w,zz_w
5613 c end diagnostics
5614 #endif
5615         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5616      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5617      &   + x(10)*yy*zz
5618         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5619      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5620      & + x(20)*yy*zz
5621         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5622      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5623      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5624      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5625      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5626      &  +x(40)*xx*yy*zz
5627         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5628      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5629      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5630      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5631      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5632      &  +x(60)*xx*yy*zz
5633         dsc_i   = 0.743d0+x(61)
5634         dp2_i   = 1.9d0+x(62)
5635         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5636      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5637         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5638      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5639         s1=(1+x(63))/(0.1d0 + dscp1)
5640         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5641         s2=(1+x(65))/(0.1d0 + dscp2)
5642         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5643         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5644      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5645 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5646 c     &   sumene4,
5647 c     &   dscp1,dscp2,sumene
5648 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5649         escloc = escloc + sumene
5650 c        write (2,*) "escloc",escloc
5651         if (.not. calc_grad) goto 1
5652 #ifdef DEBUG
5653 C
5654 C This section to check the numerical derivatives of the energy of ith side
5655 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5656 C #define DEBUG in the code to turn it on.
5657 C
5658         write (2,*) "sumene               =",sumene
5659         aincr=1.0d-7
5660         xxsave=xx
5661         xx=xx+aincr
5662         write (2,*) xx,yy,zz
5663         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5664         de_dxx_num=(sumenep-sumene)/aincr
5665         xx=xxsave
5666         write (2,*) "xx+ sumene from enesc=",sumenep
5667         yysave=yy
5668         yy=yy+aincr
5669         write (2,*) xx,yy,zz
5670         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5671         de_dyy_num=(sumenep-sumene)/aincr
5672         yy=yysave
5673         write (2,*) "yy+ sumene from enesc=",sumenep
5674         zzsave=zz
5675         zz=zz+aincr
5676         write (2,*) xx,yy,zz
5677         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5678         de_dzz_num=(sumenep-sumene)/aincr
5679         zz=zzsave
5680         write (2,*) "zz+ sumene from enesc=",sumenep
5681         costsave=cost2tab(i+1)
5682         sintsave=sint2tab(i+1)
5683         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5684         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5685         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5686         de_dt_num=(sumenep-sumene)/aincr
5687         write (2,*) " t+ sumene from enesc=",sumenep
5688         cost2tab(i+1)=costsave
5689         sint2tab(i+1)=sintsave
5690 C End of diagnostics section.
5691 #endif
5692 C
5693 C Compute the gradient of esc
5694 C
5695         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5696         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5697         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5698         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5699         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5700         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5701         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5702         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5703         pom1=(sumene3*sint2tab(i+1)+sumene1)
5704      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5705         pom2=(sumene4*cost2tab(i+1)+sumene2)
5706      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5707         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5708         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5709      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5710      &  +x(40)*yy*zz
5711         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5712         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5713      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5714      &  +x(60)*yy*zz
5715         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5716      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5717      &        +(pom1+pom2)*pom_dx
5718 #ifdef DEBUG
5719         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5720 #endif
5721 C
5722         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5723         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5724      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5725      &  +x(40)*xx*zz
5726         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5727         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5728      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5729      &  +x(59)*zz**2 +x(60)*xx*zz
5730         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5731      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5732      &        +(pom1-pom2)*pom_dy
5733 #ifdef DEBUG
5734         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5735 #endif
5736 C
5737         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5738      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5739      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5740      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5741      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5742      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5743      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5744      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5745 #ifdef DEBUG
5746         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5747 #endif
5748 C
5749         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5750      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5751      &  +pom1*pom_dt1+pom2*pom_dt2
5752 #ifdef DEBUG
5753         write(2,*), "de_dt = ", de_dt,de_dt_num
5754 #endif
5755 c
5756 C
5757        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5758        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5759        cosfac2xx=cosfac2*xx
5760        sinfac2yy=sinfac2*yy
5761        do k = 1,3
5762          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5763      &      vbld_inv(i+1)
5764          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5765      &      vbld_inv(i)
5766          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5767          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5768 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5769 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5770 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5771 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5772          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5773          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5774          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5775          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5776          dZZ_Ci1(k)=0.0d0
5777          dZZ_Ci(k)=0.0d0
5778          do j=1,3
5779            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5780      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5781            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5782      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5783          enddo
5784
5785          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5786          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5787          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5788 c
5789          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5790          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5791        enddo
5792
5793        do k=1,3
5794          dXX_Ctab(k,i)=dXX_Ci(k)
5795          dXX_C1tab(k,i)=dXX_Ci1(k)
5796          dYY_Ctab(k,i)=dYY_Ci(k)
5797          dYY_C1tab(k,i)=dYY_Ci1(k)
5798          dZZ_Ctab(k,i)=dZZ_Ci(k)
5799          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5800          dXX_XYZtab(k,i)=dXX_XYZ(k)
5801          dYY_XYZtab(k,i)=dYY_XYZ(k)
5802          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5803        enddo
5804
5805        do k = 1,3
5806 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5807 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5808 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5809 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5810 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5811 c     &    dt_dci(k)
5812 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5813 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5814          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5815      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5816          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5817      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5818          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5819      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5820        enddo
5821 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5822 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5823
5824 C to check gradient call subroutine check_grad
5825
5826     1 continue
5827       enddo
5828       return
5829       end
5830 #endif
5831 c------------------------------------------------------------------------------
5832       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5833 C
5834 C This procedure calculates two-body contact function g(rij) and its derivative:
5835 C
5836 C           eps0ij                                     !       x < -1
5837 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5838 C            0                                         !       x > 1
5839 C
5840 C where x=(rij-r0ij)/delta
5841 C
5842 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5843 C
5844       implicit none
5845       double precision rij,r0ij,eps0ij,fcont,fprimcont
5846       double precision x,x2,x4,delta
5847 c     delta=0.02D0*r0ij
5848 c      delta=0.2D0*r0ij
5849       x=(rij-r0ij)/delta
5850       if (x.lt.-1.0D0) then
5851         fcont=eps0ij
5852         fprimcont=0.0D0
5853       else if (x.le.1.0D0) then
5854         x2=x*x
5855         x4=x2*x2
5856         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5857         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5858       else
5859         fcont=0.0D0
5860         fprimcont=0.0D0
5861       endif
5862       return
5863       end
5864 c------------------------------------------------------------------------------
5865       subroutine splinthet(theti,delta,ss,ssder)
5866       implicit real*8 (a-h,o-z)
5867       include 'DIMENSIONS'
5868       include 'sizesclu.dat'
5869       include 'COMMON.VAR'
5870       include 'COMMON.GEO'
5871       thetup=pi-delta
5872       thetlow=delta
5873       if (theti.gt.pipol) then
5874         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5875       else
5876         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5877         ssder=-ssder
5878       endif
5879       return
5880       end
5881 c------------------------------------------------------------------------------
5882       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5883       implicit none
5884       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5885       double precision ksi,ksi2,ksi3,a1,a2,a3
5886       a1=fprim0*delta/(f1-f0)
5887       a2=3.0d0-2.0d0*a1
5888       a3=a1-2.0d0
5889       ksi=(x-x0)/delta
5890       ksi2=ksi*ksi
5891       ksi3=ksi2*ksi
5892       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5893       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5894       return
5895       end
5896 c------------------------------------------------------------------------------
5897       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5898       implicit none
5899       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5900       double precision ksi,ksi2,ksi3,a1,a2,a3
5901       ksi=(x-x0)/delta
5902       ksi2=ksi*ksi
5903       ksi3=ksi2*ksi
5904       a1=fprim0x*delta
5905       a2=3*(f1x-f0x)-2*fprim0x*delta
5906       a3=fprim0x*delta-2*(f1x-f0x)
5907       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5908       return
5909       end
5910 C-----------------------------------------------------------------------------
5911 #ifdef CRYST_TOR
5912 C-----------------------------------------------------------------------------
5913       subroutine etor(etors,edihcnstr,fact)
5914       implicit real*8 (a-h,o-z)
5915       include 'DIMENSIONS'
5916       include 'sizesclu.dat'
5917       include 'COMMON.VAR'
5918       include 'COMMON.GEO'
5919       include 'COMMON.LOCAL'
5920       include 'COMMON.TORSION'
5921       include 'COMMON.INTERACT'
5922       include 'COMMON.DERIV'
5923       include 'COMMON.CHAIN'
5924       include 'COMMON.NAMES'
5925       include 'COMMON.IOUNITS'
5926       include 'COMMON.FFIELD'
5927       include 'COMMON.TORCNSTR'
5928       logical lprn
5929 C Set lprn=.true. for debugging
5930       lprn=.false.
5931 c      lprn=.true.
5932       etors=0.0D0
5933       do i=iphi_start,iphi_end
5934         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5935      &      .or. itype(i).eq.ntyp1) cycle
5936         itori=itortyp(itype(i-2))
5937         itori1=itortyp(itype(i-1))
5938         phii=phi(i)
5939         gloci=0.0D0
5940 C Proline-Proline pair is a special case...
5941         if (itori.eq.3 .and. itori1.eq.3) then
5942           if (phii.gt.-dwapi3) then
5943             cosphi=dcos(3*phii)
5944             fac=1.0D0/(1.0D0-cosphi)
5945             etorsi=v1(1,3,3)*fac
5946             etorsi=etorsi+etorsi
5947             etors=etors+etorsi-v1(1,3,3)
5948             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5949           endif
5950           do j=1,3
5951             v1ij=v1(j+1,itori,itori1)
5952             v2ij=v2(j+1,itori,itori1)
5953             cosphi=dcos(j*phii)
5954             sinphi=dsin(j*phii)
5955             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5956             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5957           enddo
5958         else
5959           do j=1,nterm_old
5960             v1ij=v1(j,itori,itori1)
5961             v2ij=v2(j,itori,itori1)
5962             cosphi=dcos(j*phii)
5963             sinphi=dsin(j*phii)
5964             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5965             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5966           enddo
5967         endif
5968         if (lprn)
5969      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5970      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5971      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5972         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5973 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5974       enddo
5975 ! 6/20/98 - dihedral angle constraints
5976       edihcnstr=0.0d0
5977       do i=1,ndih_constr
5978         itori=idih_constr(i)
5979         phii=phi(itori)
5980         difi=phii-phi0(i)
5981         if (difi.gt.drange(i)) then
5982           difi=difi-drange(i)
5983           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5984           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5985         else if (difi.lt.-drange(i)) then
5986           difi=difi+drange(i)
5987           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5988           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5989         endif
5990 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5991 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5992       enddo
5993 !      write (iout,*) 'edihcnstr',edihcnstr
5994       return
5995       end
5996 c------------------------------------------------------------------------------
5997 #else
5998       subroutine etor(etors,edihcnstr,fact)
5999       implicit real*8 (a-h,o-z)
6000       include 'DIMENSIONS'
6001       include 'sizesclu.dat'
6002       include 'COMMON.VAR'
6003       include 'COMMON.GEO'
6004       include 'COMMON.LOCAL'
6005       include 'COMMON.TORSION'
6006       include 'COMMON.INTERACT'
6007       include 'COMMON.DERIV'
6008       include 'COMMON.CHAIN'
6009       include 'COMMON.NAMES'
6010       include 'COMMON.IOUNITS'
6011       include 'COMMON.FFIELD'
6012       include 'COMMON.TORCNSTR'
6013       logical lprn
6014 C Set lprn=.true. for debugging
6015       lprn=.false.
6016 c      lprn=.true.
6017       etors=0.0D0
6018       do i=iphi_start,iphi_end
6019         if (i.le.2) cycle
6020         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6021      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6022         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6023          if (iabs(itype(i)).eq.20) then
6024          iblock=2
6025          else
6026          iblock=1
6027          endif
6028         itori=itortyp(itype(i-2))
6029         itori1=itortyp(itype(i-1))
6030         phii=phi(i)
6031         gloci=0.0D0
6032 C Regular cosine and sine terms
6033         do j=1,nterm(itori,itori1,iblock)
6034           v1ij=v1(j,itori,itori1,iblock)
6035           v2ij=v2(j,itori,itori1,iblock)
6036           cosphi=dcos(j*phii)
6037           sinphi=dsin(j*phii)
6038           etors=etors+v1ij*cosphi+v2ij*sinphi
6039           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6040         enddo
6041 C Lorentz terms
6042 C                         v1
6043 C  E = SUM ----------------------------------- - v1
6044 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6045 C
6046         cosphi=dcos(0.5d0*phii)
6047         sinphi=dsin(0.5d0*phii)
6048         do j=1,nlor(itori,itori1,iblock)
6049           vl1ij=vlor1(j,itori,itori1)
6050           vl2ij=vlor2(j,itori,itori1)
6051           vl3ij=vlor3(j,itori,itori1)
6052           pom=vl2ij*cosphi+vl3ij*sinphi
6053           pom1=1.0d0/(pom*pom+1.0d0)
6054           etors=etors+vl1ij*pom1
6055           pom=-pom*pom1*pom1
6056           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6057         enddo
6058 C Subtract the constant term
6059         etors=etors-v0(itori,itori1,iblock)
6060         if (lprn)
6061      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6062      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6063      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6064         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6065 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6066  1215   continue
6067       enddo
6068 ! 6/20/98 - dihedral angle constraints
6069       edihcnstr=0.0d0
6070       do i=1,ndih_constr
6071         itori=idih_constr(i)
6072         phii=phi(itori)
6073         difi=pinorm(phii-phi0(i))
6074         edihi=0.0d0
6075         if (difi.gt.drange(i)) then
6076           difi=difi-drange(i)
6077           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6078           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6079           edihi=0.25d0*ftors(i)*difi**4
6080         else if (difi.lt.-drange(i)) then
6081           difi=difi+drange(i)
6082           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6083           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6084           edihi=0.25d0*ftors(i)*difi**4
6085         else
6086           difi=0.0d0
6087         endif
6088 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
6089 c     &    drange(i),edihi
6090 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6091 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6092       enddo
6093 !      write (iout,*) 'edihcnstr',edihcnstr
6094       return
6095       end
6096 c----------------------------------------------------------------------------
6097       subroutine etor_d(etors_d,fact2)
6098 C 6/23/01 Compute double torsional energy
6099       implicit real*8 (a-h,o-z)
6100       include 'DIMENSIONS'
6101       include 'sizesclu.dat'
6102       include 'COMMON.VAR'
6103       include 'COMMON.GEO'
6104       include 'COMMON.LOCAL'
6105       include 'COMMON.TORSION'
6106       include 'COMMON.INTERACT'
6107       include 'COMMON.DERIV'
6108       include 'COMMON.CHAIN'
6109       include 'COMMON.NAMES'
6110       include 'COMMON.IOUNITS'
6111       include 'COMMON.FFIELD'
6112       include 'COMMON.TORCNSTR'
6113       logical lprn
6114 C Set lprn=.true. for debugging
6115       lprn=.false.
6116 c     lprn=.true.
6117       etors_d=0.0D0
6118       do i=iphi_start,iphi_end-1
6119         if (i.le.3) cycle
6120          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6121      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6122      &  (itype(i+1).eq.ntyp1)) cycle
6123         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6124      &     goto 1215
6125         itori=itortyp(itype(i-2))
6126         itori1=itortyp(itype(i-1))
6127         itori2=itortyp(itype(i))
6128         phii=phi(i)
6129         phii1=phi(i+1)
6130         gloci1=0.0D0
6131         gloci2=0.0D0
6132         iblock=1
6133         if (iabs(itype(i+1)).eq.20) iblock=2
6134 C Regular cosine and sine terms
6135        do j=1,ntermd_1(itori,itori1,itori2,iblock)
6136           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6137           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6138           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6139           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6140           cosphi1=dcos(j*phii)
6141           sinphi1=dsin(j*phii)
6142           cosphi2=dcos(j*phii1)
6143           sinphi2=dsin(j*phii1)
6144           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6145      &     v2cij*cosphi2+v2sij*sinphi2
6146           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6147           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6148         enddo
6149         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6150           do l=1,k-1
6151             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6152             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6153             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6154             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6155             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6156             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6157             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6158             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6159             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6160      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6161             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6162      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6163             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6164      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6165           enddo
6166         enddo
6167         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6168         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6169  1215   continue
6170       enddo
6171       return
6172       end
6173 #endif
6174 c------------------------------------------------------------------------------
6175       subroutine eback_sc_corr(esccor)
6176 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6177 c        conformational states; temporarily implemented as differences
6178 c        between UNRES torsional potentials (dependent on three types of
6179 c        residues) and the torsional potentials dependent on all 20 types
6180 c        of residues computed from AM1 energy surfaces of terminally-blocked
6181 c        amino-acid residues.
6182       implicit real*8 (a-h,o-z)
6183       include 'DIMENSIONS'
6184       include 'sizesclu.dat'
6185       include 'COMMON.VAR'
6186       include 'COMMON.GEO'
6187       include 'COMMON.LOCAL'
6188       include 'COMMON.TORSION'
6189       include 'COMMON.SCCOR'
6190       include 'COMMON.INTERACT'
6191       include 'COMMON.DERIV'
6192       include 'COMMON.CHAIN'
6193       include 'COMMON.NAMES'
6194       include 'COMMON.IOUNITS'
6195       include 'COMMON.FFIELD'
6196       include 'COMMON.CONTROL'
6197       logical lprn
6198 C Set lprn=.true. for debugging
6199       lprn=.false.
6200 c      lprn=.true.
6201 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6202       esccor=0.0D0
6203       do i=itau_start,itau_end
6204         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6205         esccor_ii=0.0D0
6206         isccori=isccortyp(itype(i-2))
6207         isccori1=isccortyp(itype(i-1))
6208         phii=phi(i)
6209         do intertyp=1,3 !intertyp
6210 cc Added 09 May 2012 (Adasko)
6211 cc  Intertyp means interaction type of backbone mainchain correlation:
6212 c   1 = SC...Ca...Ca...Ca
6213 c   2 = Ca...Ca...Ca...SC
6214 c   3 = SC...Ca...Ca...SCi
6215         gloci=0.0D0
6216         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6217      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6218      &      (itype(i-1).eq.ntyp1)))
6219      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6220      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6221      &     .or.(itype(i).eq.ntyp1)))
6222      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6223      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6224      &      (itype(i-3).eq.ntyp1)))) cycle
6225         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6226         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6227      & cycle
6228        do j=1,nterm_sccor(isccori,isccori1)
6229           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6230           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6231           cosphi=dcos(j*tauangle(intertyp,i))
6232           sinphi=dsin(j*tauangle(intertyp,i))
6233            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6234 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6235          enddo
6236 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
6237 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
6238         if (lprn)
6239      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6240      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6241      &  (v1sccor(j,1,itori,itori1),j=1,6),
6242      &  (v2sccor(j,1,itori,itori1),j=1,6)
6243         gsccor_loc(i-3)=gloci
6244        enddo !intertyp
6245       enddo
6246       return
6247       end
6248 c------------------------------------------------------------------------------
6249       subroutine multibody(ecorr)
6250 C This subroutine calculates multi-body contributions to energy following
6251 C the idea of Skolnick et al. If side chains I and J make a contact and
6252 C at the same time side chains I+1 and J+1 make a contact, an extra
6253 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6254       implicit real*8 (a-h,o-z)
6255       include 'DIMENSIONS'
6256       include 'COMMON.IOUNITS'
6257       include 'COMMON.DERIV'
6258       include 'COMMON.INTERACT'
6259       include 'COMMON.CONTACTS'
6260       double precision gx(3),gx1(3)
6261       logical lprn
6262
6263 C Set lprn=.true. for debugging
6264       lprn=.false.
6265
6266       if (lprn) then
6267         write (iout,'(a)') 'Contact function values:'
6268         do i=nnt,nct-2
6269           write (iout,'(i2,20(1x,i2,f10.5))')
6270      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6271         enddo
6272       endif
6273       ecorr=0.0D0
6274       do i=nnt,nct
6275         do j=1,3
6276           gradcorr(j,i)=0.0D0
6277           gradxorr(j,i)=0.0D0
6278         enddo
6279       enddo
6280       do i=nnt,nct-2
6281
6282         DO ISHIFT = 3,4
6283
6284         i1=i+ishift
6285         num_conti=num_cont(i)
6286         num_conti1=num_cont(i1)
6287         do jj=1,num_conti
6288           j=jcont(jj,i)
6289           do kk=1,num_conti1
6290             j1=jcont(kk,i1)
6291             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6292 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6293 cd   &                   ' ishift=',ishift
6294 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6295 C The system gains extra energy.
6296               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6297             endif   ! j1==j+-ishift
6298           enddo     ! kk
6299         enddo       ! jj
6300
6301         ENDDO ! ISHIFT
6302
6303       enddo         ! i
6304       return
6305       end
6306 c------------------------------------------------------------------------------
6307       double precision function esccorr(i,j,k,l,jj,kk)
6308       implicit real*8 (a-h,o-z)
6309       include 'DIMENSIONS'
6310       include 'COMMON.IOUNITS'
6311       include 'COMMON.DERIV'
6312       include 'COMMON.INTERACT'
6313       include 'COMMON.CONTACTS'
6314       double precision gx(3),gx1(3)
6315       logical lprn
6316       lprn=.false.
6317       eij=facont(jj,i)
6318       ekl=facont(kk,k)
6319 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6320 C Calculate the multi-body contribution to energy.
6321 C Calculate multi-body contributions to the gradient.
6322 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6323 cd   & k,l,(gacont(m,kk,k),m=1,3)
6324       do m=1,3
6325         gx(m) =ekl*gacont(m,jj,i)
6326         gx1(m)=eij*gacont(m,kk,k)
6327         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6328         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6329         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6330         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6331       enddo
6332       do m=i,j-1
6333         do ll=1,3
6334           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6335         enddo
6336       enddo
6337       do m=k,l-1
6338         do ll=1,3
6339           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6340         enddo
6341       enddo
6342       esccorr=-eij*ekl
6343       return
6344       end
6345 c------------------------------------------------------------------------------
6346 #ifdef MPL
6347       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6348       implicit real*8 (a-h,o-z)
6349       include 'DIMENSIONS'
6350       integer dimen1,dimen2,atom,indx
6351       double precision buffer(dimen1,dimen2)
6352       double precision zapas
6353       common /contacts_hb/ zapas(3,20,maxres,7),
6354      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6355      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6356       num_kont=num_cont_hb(atom)
6357       do i=1,num_kont
6358         do k=1,7
6359           do j=1,3
6360             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6361           enddo ! j
6362         enddo ! k
6363         buffer(i,indx+22)=facont_hb(i,atom)
6364         buffer(i,indx+23)=ees0p(i,atom)
6365         buffer(i,indx+24)=ees0m(i,atom)
6366         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6367       enddo ! i
6368       buffer(1,indx+26)=dfloat(num_kont)
6369       return
6370       end
6371 c------------------------------------------------------------------------------
6372       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6373       implicit real*8 (a-h,o-z)
6374       include 'DIMENSIONS'
6375       integer dimen1,dimen2,atom,indx
6376       double precision buffer(dimen1,dimen2)
6377       double precision zapas
6378       common /contacts_hb/ zapas(3,ntyp,maxres,7),
6379      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
6380      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
6381       num_kont=buffer(1,indx+26)
6382       num_kont_old=num_cont_hb(atom)
6383       num_cont_hb(atom)=num_kont+num_kont_old
6384       do i=1,num_kont
6385         ii=i+num_kont_old
6386         do k=1,7
6387           do j=1,3
6388             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6389           enddo ! j
6390         enddo ! k
6391         facont_hb(ii,atom)=buffer(i,indx+22)
6392         ees0p(ii,atom)=buffer(i,indx+23)
6393         ees0m(ii,atom)=buffer(i,indx+24)
6394         jcont_hb(ii,atom)=buffer(i,indx+25)
6395       enddo ! i
6396       return
6397       end
6398 c------------------------------------------------------------------------------
6399 #endif
6400       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6401 C This subroutine calculates multi-body contributions to hydrogen-bonding
6402       implicit real*8 (a-h,o-z)
6403       include 'DIMENSIONS'
6404       include 'sizesclu.dat'
6405       include 'COMMON.IOUNITS'
6406 #ifdef MPL
6407       include 'COMMON.INFO'
6408 #endif
6409       include 'COMMON.FFIELD'
6410       include 'COMMON.DERIV'
6411       include 'COMMON.INTERACT'
6412       include 'COMMON.CONTACTS'
6413 #ifdef MPL
6414       parameter (max_cont=maxconts)
6415       parameter (max_dim=2*(8*3+2))
6416       parameter (msglen1=max_cont*max_dim*4)
6417       parameter (msglen2=2*msglen1)
6418       integer source,CorrelType,CorrelID,Error
6419       double precision buffer(max_cont,max_dim)
6420 #endif
6421       double precision gx(3),gx1(3)
6422       logical lprn,ldone
6423
6424 C Set lprn=.true. for debugging
6425       lprn=.false.
6426 #ifdef MPL
6427       n_corr=0
6428       n_corr1=0
6429       if (fgProcs.le.1) goto 30
6430       if (lprn) then
6431         write (iout,'(a)') 'Contact function values:'
6432         do i=nnt,nct-2
6433           write (iout,'(2i3,50(1x,i2,f5.2))')
6434      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6435      &    j=1,num_cont_hb(i))
6436         enddo
6437       endif
6438 C Caution! Following code assumes that electrostatic interactions concerning
6439 C a given atom are split among at most two processors!
6440       CorrelType=477
6441       CorrelID=MyID+1
6442       ldone=.false.
6443       do i=1,max_cont
6444         do j=1,max_dim
6445           buffer(i,j)=0.0D0
6446         enddo
6447       enddo
6448       mm=mod(MyRank,2)
6449 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6450       if (mm) 20,20,10
6451    10 continue
6452 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6453       if (MyRank.gt.0) then
6454 C Send correlation contributions to the preceding processor
6455         msglen=msglen1
6456         nn=num_cont_hb(iatel_s)
6457         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6458 cd      write (iout,*) 'The BUFFER array:'
6459 cd      do i=1,nn
6460 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6461 cd      enddo
6462         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6463           msglen=msglen2
6464             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6465 C Clear the contacts of the atom passed to the neighboring processor
6466         nn=num_cont_hb(iatel_s+1)
6467 cd      do i=1,nn
6468 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6469 cd      enddo
6470             num_cont_hb(iatel_s)=0
6471         endif
6472 cd      write (iout,*) 'Processor ',MyID,MyRank,
6473 cd   & ' is sending correlation contribution to processor',MyID-1,
6474 cd   & ' msglen=',msglen
6475 cd      write (*,*) 'Processor ',MyID,MyRank,
6476 cd   & ' is sending correlation contribution to processor',MyID-1,
6477 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6478         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6479 cd      write (iout,*) 'Processor ',MyID,
6480 cd   & ' has sent correlation contribution to processor',MyID-1,
6481 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6482 cd      write (*,*) 'Processor ',MyID,
6483 cd   & ' has sent correlation contribution to processor',MyID-1,
6484 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6485         msglen=msglen1
6486       endif ! (MyRank.gt.0)
6487       if (ldone) goto 30
6488       ldone=.true.
6489    20 continue
6490 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6491       if (MyRank.lt.fgProcs-1) then
6492 C Receive correlation contributions from the next processor
6493         msglen=msglen1
6494         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6495 cd      write (iout,*) 'Processor',MyID,
6496 cd   & ' is receiving correlation contribution from processor',MyID+1,
6497 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6498 cd      write (*,*) 'Processor',MyID,
6499 cd   & ' is receiving correlation contribution from processor',MyID+1,
6500 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6501         nbytes=-1
6502         do while (nbytes.le.0)
6503           call mp_probe(MyID+1,CorrelType,nbytes)
6504         enddo
6505 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6506         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6507 cd      write (iout,*) 'Processor',MyID,
6508 cd   & ' has received correlation contribution from processor',MyID+1,
6509 cd   & ' msglen=',msglen,' nbytes=',nbytes
6510 cd      write (iout,*) 'The received BUFFER array:'
6511 cd      do i=1,max_cont
6512 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6513 cd      enddo
6514         if (msglen.eq.msglen1) then
6515           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6516         else if (msglen.eq.msglen2)  then
6517           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6518           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6519         else
6520           write (iout,*)
6521      & 'ERROR!!!! message length changed while processing correlations.'
6522           write (*,*)
6523      & 'ERROR!!!! message length changed while processing correlations.'
6524           call mp_stopall(Error)
6525         endif ! msglen.eq.msglen1
6526       endif ! MyRank.lt.fgProcs-1
6527       if (ldone) goto 30
6528       ldone=.true.
6529       goto 10
6530    30 continue
6531 #endif
6532       if (lprn) then
6533         write (iout,'(a)') 'Contact function values:'
6534         do i=nnt,nct-2
6535           write (iout,'(2i3,50(1x,i2,f5.2))')
6536      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6537      &    j=1,num_cont_hb(i))
6538         enddo
6539       endif
6540       ecorr=0.0D0
6541 C Remove the loop below after debugging !!!
6542       do i=nnt,nct
6543         do j=1,3
6544           gradcorr(j,i)=0.0D0
6545           gradxorr(j,i)=0.0D0
6546         enddo
6547       enddo
6548 C Calculate the local-electrostatic correlation terms
6549       do i=iatel_s,iatel_e+1
6550         i1=i+1
6551         num_conti=num_cont_hb(i)
6552         num_conti1=num_cont_hb(i+1)
6553         do jj=1,num_conti
6554           j=jcont_hb(jj,i)
6555           do kk=1,num_conti1
6556             j1=jcont_hb(kk,i1)
6557 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6558 c     &         ' jj=',jj,' kk=',kk
6559             if (j1.eq.j+1 .or. j1.eq.j-1) then
6560 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6561 C The system gains extra energy.
6562               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6563               n_corr=n_corr+1
6564             else if (j1.eq.j) then
6565 C Contacts I-J and I-(J+1) occur simultaneously.
6566 C The system loses extra energy.
6567 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6568             endif
6569           enddo ! kk
6570           do kk=1,num_conti
6571             j1=jcont_hb(kk,i)
6572 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6573 c    &         ' jj=',jj,' kk=',kk
6574             if (j1.eq.j+1) then
6575 C Contacts I-J and (I+1)-J occur simultaneously.
6576 C The system loses extra energy.
6577 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6578             endif ! j1==j+1
6579           enddo ! kk
6580         enddo ! jj
6581       enddo ! i
6582       return
6583       end
6584 c------------------------------------------------------------------------------
6585       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6586      &  n_corr1)
6587 C This subroutine calculates multi-body contributions to hydrogen-bonding
6588       implicit real*8 (a-h,o-z)
6589       include 'DIMENSIONS'
6590       include 'sizesclu.dat'
6591       include 'COMMON.IOUNITS'
6592 #ifdef MPL
6593       include 'COMMON.INFO'
6594 #endif
6595       include 'COMMON.FFIELD'
6596       include 'COMMON.DERIV'
6597       include 'COMMON.INTERACT'
6598       include 'COMMON.CONTACTS'
6599 #ifdef MPL
6600       parameter (max_cont=maxconts)
6601       parameter (max_dim=2*(8*3+2))
6602       parameter (msglen1=max_cont*max_dim*4)
6603       parameter (msglen2=2*msglen1)
6604       integer source,CorrelType,CorrelID,Error
6605       double precision buffer(max_cont,max_dim)
6606 #endif
6607       double precision gx(3),gx1(3)
6608       logical lprn,ldone
6609
6610 C Set lprn=.true. for debugging
6611       lprn=.false.
6612       eturn6=0.0d0
6613 #ifdef MPL
6614       n_corr=0
6615       n_corr1=0
6616       if (fgProcs.le.1) goto 30
6617       if (lprn) then
6618         write (iout,'(a)') 'Contact function values:'
6619         do i=nnt,nct-2
6620           write (iout,'(2i3,50(1x,i2,f5.2))')
6621      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6622      &    j=1,num_cont_hb(i))
6623         enddo
6624       endif
6625 C Caution! Following code assumes that electrostatic interactions concerning
6626 C a given atom are split among at most two processors!
6627       CorrelType=477
6628       CorrelID=MyID+1
6629       ldone=.false.
6630       do i=1,max_cont
6631         do j=1,max_dim
6632           buffer(i,j)=0.0D0
6633         enddo
6634       enddo
6635       mm=mod(MyRank,2)
6636 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6637       if (mm) 20,20,10
6638    10 continue
6639 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6640       if (MyRank.gt.0) then
6641 C Send correlation contributions to the preceding processor
6642         msglen=msglen1
6643         nn=num_cont_hb(iatel_s)
6644         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6645 cd      write (iout,*) 'The BUFFER array:'
6646 cd      do i=1,nn
6647 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6648 cd      enddo
6649         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6650           msglen=msglen2
6651             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6652 C Clear the contacts of the atom passed to the neighboring processor
6653         nn=num_cont_hb(iatel_s+1)
6654 cd      do i=1,nn
6655 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6656 cd      enddo
6657             num_cont_hb(iatel_s)=0
6658         endif
6659 cd      write (iout,*) 'Processor ',MyID,MyRank,
6660 cd   & ' is sending correlation contribution to processor',MyID-1,
6661 cd   & ' msglen=',msglen
6662 cd      write (*,*) 'Processor ',MyID,MyRank,
6663 cd   & ' is sending correlation contribution to processor',MyID-1,
6664 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6665         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6666 cd      write (iout,*) 'Processor ',MyID,
6667 cd   & ' has sent correlation contribution to processor',MyID-1,
6668 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6669 cd      write (*,*) 'Processor ',MyID,
6670 cd   & ' has sent correlation contribution to processor',MyID-1,
6671 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6672         msglen=msglen1
6673       endif ! (MyRank.gt.0)
6674       if (ldone) goto 30
6675       ldone=.true.
6676    20 continue
6677 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6678       if (MyRank.lt.fgProcs-1) then
6679 C Receive correlation contributions from the next processor
6680         msglen=msglen1
6681         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6682 cd      write (iout,*) 'Processor',MyID,
6683 cd   & ' is receiving correlation contribution from processor',MyID+1,
6684 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6685 cd      write (*,*) 'Processor',MyID,
6686 cd   & ' is receiving correlation contribution from processor',MyID+1,
6687 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6688         nbytes=-1
6689         do while (nbytes.le.0)
6690           call mp_probe(MyID+1,CorrelType,nbytes)
6691         enddo
6692 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6693         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6694 cd      write (iout,*) 'Processor',MyID,
6695 cd   & ' has received correlation contribution from processor',MyID+1,
6696 cd   & ' msglen=',msglen,' nbytes=',nbytes
6697 cd      write (iout,*) 'The received BUFFER array:'
6698 cd      do i=1,max_cont
6699 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6700 cd      enddo
6701         if (msglen.eq.msglen1) then
6702           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6703         else if (msglen.eq.msglen2)  then
6704           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6705           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6706         else
6707           write (iout,*)
6708      & 'ERROR!!!! message length changed while processing correlations.'
6709           write (*,*)
6710      & 'ERROR!!!! message length changed while processing correlations.'
6711           call mp_stopall(Error)
6712         endif ! msglen.eq.msglen1
6713       endif ! MyRank.lt.fgProcs-1
6714       if (ldone) goto 30
6715       ldone=.true.
6716       goto 10
6717    30 continue
6718 #endif
6719       if (lprn) then
6720         write (iout,'(a)') 'Contact function values:'
6721         do i=nnt,nct-2
6722           write (iout,'(2i3,50(1x,i2,f5.2))')
6723      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6724      &    j=1,num_cont_hb(i))
6725         enddo
6726       endif
6727       ecorr=0.0D0
6728       ecorr5=0.0d0
6729       ecorr6=0.0d0
6730 C Remove the loop below after debugging !!!
6731       do i=nnt,nct
6732         do j=1,3
6733           gradcorr(j,i)=0.0D0
6734           gradxorr(j,i)=0.0D0
6735         enddo
6736       enddo
6737 C Calculate the dipole-dipole interaction energies
6738       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6739       do i=iatel_s,iatel_e+1
6740         num_conti=num_cont_hb(i)
6741         do jj=1,num_conti
6742           j=jcont_hb(jj,i)
6743           call dipole(i,j,jj)
6744         enddo
6745       enddo
6746       endif
6747 C Calculate the local-electrostatic correlation terms
6748       do i=iatel_s,iatel_e+1
6749         i1=i+1
6750         num_conti=num_cont_hb(i)
6751         num_conti1=num_cont_hb(i+1)
6752         do jj=1,num_conti
6753           j=jcont_hb(jj,i)
6754           do kk=1,num_conti1
6755             j1=jcont_hb(kk,i1)
6756 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6757 c     &         ' jj=',jj,' kk=',kk
6758             if (j1.eq.j+1 .or. j1.eq.j-1) then
6759 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6760 C The system gains extra energy.
6761               n_corr=n_corr+1
6762               sqd1=dsqrt(d_cont(jj,i))
6763               sqd2=dsqrt(d_cont(kk,i1))
6764               sred_geom = sqd1*sqd2
6765               IF (sred_geom.lt.cutoff_corr) THEN
6766                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6767      &            ekont,fprimcont)
6768 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6769 c     &         ' jj=',jj,' kk=',kk
6770                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6771                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6772                 do l=1,3
6773                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6774                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6775                 enddo
6776                 n_corr1=n_corr1+1
6777 cd               write (iout,*) 'sred_geom=',sred_geom,
6778 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6779                 call calc_eello(i,j,i+1,j1,jj,kk)
6780                 if (wcorr4.gt.0.0d0)
6781      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6782                 if (wcorr5.gt.0.0d0)
6783      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6784 c                print *,"wcorr5",ecorr5
6785 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6786 cd                write(2,*)'ijkl',i,j,i+1,j1
6787                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6788      &               .or. wturn6.eq.0.0d0))then
6789 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6790                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6791 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6792 cd     &            'ecorr6=',ecorr6
6793 cd                write (iout,'(4e15.5)') sred_geom,
6794 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6795 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6796 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6797                 else if (wturn6.gt.0.0d0
6798      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6799 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6800                   eturn6=eturn6+eello_turn6(i,jj,kk)
6801 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6802                 endif
6803               ENDIF
6804 1111          continue
6805             else if (j1.eq.j) then
6806 C Contacts I-J and I-(J+1) occur simultaneously.
6807 C The system loses extra energy.
6808 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6809             endif
6810           enddo ! kk
6811           do kk=1,num_conti
6812             j1=jcont_hb(kk,i)
6813 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6814 c    &         ' jj=',jj,' kk=',kk
6815             if (j1.eq.j+1) then
6816 C Contacts I-J and (I+1)-J occur simultaneously.
6817 C The system loses extra energy.
6818 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6819             endif ! j1==j+1
6820           enddo ! kk
6821         enddo ! jj
6822       enddo ! i
6823       return
6824       end
6825 c------------------------------------------------------------------------------
6826       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6827       implicit real*8 (a-h,o-z)
6828       include 'DIMENSIONS'
6829       include 'COMMON.IOUNITS'
6830       include 'COMMON.DERIV'
6831       include 'COMMON.INTERACT'
6832       include 'COMMON.CONTACTS'
6833       include 'COMMON.SHIELD'
6834
6835       double precision gx(3),gx1(3)
6836       logical lprn
6837       lprn=.false.
6838       eij=facont_hb(jj,i)
6839       ekl=facont_hb(kk,k)
6840       ees0pij=ees0p(jj,i)
6841       ees0pkl=ees0p(kk,k)
6842       ees0mij=ees0m(jj,i)
6843       ees0mkl=ees0m(kk,k)
6844       ekont=eij*ekl
6845       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6846 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6847 C Following 4 lines for diagnostics.
6848 cd    ees0pkl=0.0D0
6849 cd    ees0pij=1.0D0
6850 cd    ees0mkl=0.0D0
6851 cd    ees0mij=1.0D0
6852 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6853 c    &   ' and',k,l
6854 c     write (iout,*)'Contacts have occurred for peptide groups',
6855 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6856 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6857 C Calculate the multi-body contribution to energy.
6858       ecorr=ecorr+ekont*ees
6859       if (calc_grad) then
6860 C Calculate multi-body contributions to the gradient.
6861       do ll=1,3
6862         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6863         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6864      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6865      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6866         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6867      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6868      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6869         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6870         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6871      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6872      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6873         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6874      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6875      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6876       enddo
6877       do m=i+1,j-1
6878         do ll=1,3
6879           gradcorr(ll,m)=gradcorr(ll,m)+
6880      &     ees*ekl*gacont_hbr(ll,jj,i)-
6881      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6882      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6883         enddo
6884       enddo
6885       do m=k+1,l-1
6886         do ll=1,3
6887           gradcorr(ll,m)=gradcorr(ll,m)+
6888      &     ees*eij*gacont_hbr(ll,kk,k)-
6889      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6890      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6891         enddo
6892       enddo
6893       if (shield_mode.gt.0) then
6894        j=ees0plist(jj,i)
6895        l=ees0plist(kk,k)
6896 C        print *,i,j,fac_shield(i),fac_shield(j),
6897 C     &fac_shield(k),fac_shield(l)
6898         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6899      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6900           do ilist=1,ishield_list(i)
6901            iresshield=shield_list(ilist,i)
6902            do m=1,3
6903            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6904 C     &      *2.0
6905            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6906      &              rlocshield
6907      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6908             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6909      &+rlocshield
6910            enddo
6911           enddo
6912           do ilist=1,ishield_list(j)
6913            iresshield=shield_list(ilist,j)
6914            do m=1,3
6915            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6916 C     &     *2.0
6917            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6918      &              rlocshield
6919      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6920            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6921      &     +rlocshield
6922            enddo
6923           enddo
6924           do ilist=1,ishield_list(k)
6925            iresshield=shield_list(ilist,k)
6926            do m=1,3
6927            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6928 C     &     *2.0
6929            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6930      &              rlocshield
6931      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6932            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6933      &     +rlocshield
6934            enddo
6935           enddo
6936           do ilist=1,ishield_list(l)
6937            iresshield=shield_list(ilist,l)
6938            do m=1,3
6939            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6940 C     &     *2.0
6941            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6942      &              rlocshield
6943      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6944            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6945      &     +rlocshield
6946            enddo
6947           enddo
6948 C          print *,gshieldx(m,iresshield)
6949           do m=1,3
6950             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6951      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6952             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6953      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6954             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6955      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6956             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6957      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6958
6959             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6960      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6961             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6962      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6963             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6964      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6965             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6966      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6967
6968            enddo
6969       endif
6970       endif
6971       endif
6972       ehbcorr=ekont*ees
6973       return
6974       end
6975 C---------------------------------------------------------------------------
6976       subroutine dipole(i,j,jj)
6977       implicit real*8 (a-h,o-z)
6978       include 'DIMENSIONS'
6979       include 'sizesclu.dat'
6980       include 'COMMON.IOUNITS'
6981       include 'COMMON.CHAIN'
6982       include 'COMMON.FFIELD'
6983       include 'COMMON.DERIV'
6984       include 'COMMON.INTERACT'
6985       include 'COMMON.CONTACTS'
6986       include 'COMMON.TORSION'
6987       include 'COMMON.VAR'
6988       include 'COMMON.GEO'
6989       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6990      &  auxmat(2,2)
6991       iti1 = itortyp(itype(i+1))
6992       if (j.lt.nres-1) then
6993         if (itype(j).le.ntyp) then
6994           itj1 = itortyp(itype(j+1))
6995         else
6996           itj1=ntortyp+1
6997         endif
6998       else
6999         itj1=ntortyp+1
7000       endif
7001       do iii=1,2
7002         dipi(iii,1)=Ub2(iii,i)
7003         dipderi(iii)=Ub2der(iii,i)
7004         dipi(iii,2)=b1(iii,iti1)
7005         dipj(iii,1)=Ub2(iii,j)
7006         dipderj(iii)=Ub2der(iii,j)
7007         dipj(iii,2)=b1(iii,itj1)
7008       enddo
7009       kkk=0
7010       do iii=1,2
7011         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7012         do jjj=1,2
7013           kkk=kkk+1
7014           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7015         enddo
7016       enddo
7017       if (.not.calc_grad) return
7018       do kkk=1,5
7019         do lll=1,3
7020           mmm=0
7021           do iii=1,2
7022             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7023      &        auxvec(1))
7024             do jjj=1,2
7025               mmm=mmm+1
7026               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7027             enddo
7028           enddo
7029         enddo
7030       enddo
7031       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7032       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7033       do iii=1,2
7034         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7035       enddo
7036       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7037       do iii=1,2
7038         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7039       enddo
7040       return
7041       end
7042 C---------------------------------------------------------------------------
7043       subroutine calc_eello(i,j,k,l,jj,kk)
7044 C
7045 C This subroutine computes matrices and vectors needed to calculate
7046 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7047 C
7048       implicit real*8 (a-h,o-z)
7049       include 'DIMENSIONS'
7050       include 'sizesclu.dat'
7051       include 'COMMON.IOUNITS'
7052       include 'COMMON.CHAIN'
7053       include 'COMMON.DERIV'
7054       include 'COMMON.INTERACT'
7055       include 'COMMON.CONTACTS'
7056       include 'COMMON.TORSION'
7057       include 'COMMON.VAR'
7058       include 'COMMON.GEO'
7059       include 'COMMON.FFIELD'
7060       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7061      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7062       logical lprn
7063       common /kutas/ lprn
7064 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7065 cd     & ' jj=',jj,' kk=',kk
7066 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7067       do iii=1,2
7068         do jjj=1,2
7069           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7070           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7071         enddo
7072       enddo
7073       call transpose2(aa1(1,1),aa1t(1,1))
7074       call transpose2(aa2(1,1),aa2t(1,1))
7075       do kkk=1,5
7076         do lll=1,3
7077           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7078      &      aa1tder(1,1,lll,kkk))
7079           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7080      &      aa2tder(1,1,lll,kkk))
7081         enddo
7082       enddo
7083       if (l.eq.j+1) then
7084 C parallel orientation of the two CA-CA-CA frames.
7085 c        if (i.gt.1) then
7086         if (i.gt.1 .and. itype(i).le.ntyp) then
7087           iti=itortyp(itype(i))
7088         else
7089           iti=ntortyp+1
7090         endif
7091         itk1=itortyp(itype(k+1))
7092         itj=itortyp(itype(j))
7093 c        if (l.lt.nres-1) then
7094         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7095           itl1=itortyp(itype(l+1))
7096         else
7097           itl1=ntortyp+1
7098         endif
7099 C A1 kernel(j+1) A2T
7100 cd        do iii=1,2
7101 cd          write (iout,'(3f10.5,5x,3f10.5)')
7102 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7103 cd        enddo
7104         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7105      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7106      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7107 C Following matrices are needed only for 6-th order cumulants
7108         IF (wcorr6.gt.0.0d0) THEN
7109         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7110      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7111      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7112         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7113      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7114      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7115      &   ADtEAderx(1,1,1,1,1,1))
7116         lprn=.false.
7117         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7118      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7119      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7120      &   ADtEA1derx(1,1,1,1,1,1))
7121         ENDIF
7122 C End 6-th order cumulants
7123 cd        lprn=.false.
7124 cd        if (lprn) then
7125 cd        write (2,*) 'In calc_eello6'
7126 cd        do iii=1,2
7127 cd          write (2,*) 'iii=',iii
7128 cd          do kkk=1,5
7129 cd            write (2,*) 'kkk=',kkk
7130 cd            do jjj=1,2
7131 cd              write (2,'(3(2f10.5),5x)')
7132 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7133 cd            enddo
7134 cd          enddo
7135 cd        enddo
7136 cd        endif
7137         call transpose2(EUgder(1,1,k),auxmat(1,1))
7138         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7139         call transpose2(EUg(1,1,k),auxmat(1,1))
7140         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7141         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7142         do iii=1,2
7143           do kkk=1,5
7144             do lll=1,3
7145               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7146      &          EAEAderx(1,1,lll,kkk,iii,1))
7147             enddo
7148           enddo
7149         enddo
7150 C A1T kernel(i+1) A2
7151         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7152      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7153      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7154 C Following matrices are needed only for 6-th order cumulants
7155         IF (wcorr6.gt.0.0d0) THEN
7156         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7157      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7158      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7159         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7160      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7161      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7162      &   ADtEAderx(1,1,1,1,1,2))
7163         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7164      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7165      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7166      &   ADtEA1derx(1,1,1,1,1,2))
7167         ENDIF
7168 C End 6-th order cumulants
7169         call transpose2(EUgder(1,1,l),auxmat(1,1))
7170         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7171         call transpose2(EUg(1,1,l),auxmat(1,1))
7172         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7173         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7174         do iii=1,2
7175           do kkk=1,5
7176             do lll=1,3
7177               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7178      &          EAEAderx(1,1,lll,kkk,iii,2))
7179             enddo
7180           enddo
7181         enddo
7182 C AEAb1 and AEAb2
7183 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7184 C They are needed only when the fifth- or the sixth-order cumulants are
7185 C indluded.
7186         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7187         call transpose2(AEA(1,1,1),auxmat(1,1))
7188         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7189         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7190         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7191         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7192         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7193         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7194         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7195         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7196         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7197         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7198         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7199         call transpose2(AEA(1,1,2),auxmat(1,1))
7200         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7201         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7202         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7203         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7204         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7205         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7206         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7207         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7208         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7209         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7210         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7211 C Calculate the Cartesian derivatives of the vectors.
7212         do iii=1,2
7213           do kkk=1,5
7214             do lll=1,3
7215               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7216               call matvec2(auxmat(1,1),b1(1,iti),
7217      &          AEAb1derx(1,lll,kkk,iii,1,1))
7218               call matvec2(auxmat(1,1),Ub2(1,i),
7219      &          AEAb2derx(1,lll,kkk,iii,1,1))
7220               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7221      &          AEAb1derx(1,lll,kkk,iii,2,1))
7222               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7223      &          AEAb2derx(1,lll,kkk,iii,2,1))
7224               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7225               call matvec2(auxmat(1,1),b1(1,itj),
7226      &          AEAb1derx(1,lll,kkk,iii,1,2))
7227               call matvec2(auxmat(1,1),Ub2(1,j),
7228      &          AEAb2derx(1,lll,kkk,iii,1,2))
7229               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7230      &          AEAb1derx(1,lll,kkk,iii,2,2))
7231               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7232      &          AEAb2derx(1,lll,kkk,iii,2,2))
7233             enddo
7234           enddo
7235         enddo
7236         ENDIF
7237 C End vectors
7238       else
7239 C Antiparallel orientation of the two CA-CA-CA frames.
7240 c        if (i.gt.1) then
7241         if (i.gt.1 .and. itype(i).le.ntyp) then
7242           iti=itortyp(itype(i))
7243         else
7244           iti=ntortyp+1
7245         endif
7246         itk1=itortyp(itype(k+1))
7247         itl=itortyp(itype(l))
7248         itj=itortyp(itype(j))
7249 c        if (j.lt.nres-1) then
7250         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7251           itj1=itortyp(itype(j+1))
7252         else
7253           itj1=ntortyp+1
7254         endif
7255 C A2 kernel(j-1)T A1T
7256         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7257      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7258      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7259 C Following matrices are needed only for 6-th order cumulants
7260         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7261      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7262         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7263      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7264      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7265         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7266      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7267      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7268      &   ADtEAderx(1,1,1,1,1,1))
7269         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7270      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7271      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7272      &   ADtEA1derx(1,1,1,1,1,1))
7273         ENDIF
7274 C End 6-th order cumulants
7275         call transpose2(EUgder(1,1,k),auxmat(1,1))
7276         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7277         call transpose2(EUg(1,1,k),auxmat(1,1))
7278         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7279         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7280         do iii=1,2
7281           do kkk=1,5
7282             do lll=1,3
7283               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7284      &          EAEAderx(1,1,lll,kkk,iii,1))
7285             enddo
7286           enddo
7287         enddo
7288 C A2T kernel(i+1)T A1
7289         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7290      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7291      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7292 C Following matrices are needed only for 6-th order cumulants
7293         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7294      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7295         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7296      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7297      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7298         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7299      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7300      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7301      &   ADtEAderx(1,1,1,1,1,2))
7302         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7303      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7304      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7305      &   ADtEA1derx(1,1,1,1,1,2))
7306         ENDIF
7307 C End 6-th order cumulants
7308         call transpose2(EUgder(1,1,j),auxmat(1,1))
7309         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7310         call transpose2(EUg(1,1,j),auxmat(1,1))
7311         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7312         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7313         do iii=1,2
7314           do kkk=1,5
7315             do lll=1,3
7316               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7317      &          EAEAderx(1,1,lll,kkk,iii,2))
7318             enddo
7319           enddo
7320         enddo
7321 C AEAb1 and AEAb2
7322 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7323 C They are needed only when the fifth- or the sixth-order cumulants are
7324 C indluded.
7325         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7326      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7327         call transpose2(AEA(1,1,1),auxmat(1,1))
7328         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7329         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7330         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7331         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7332         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7333         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7334         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7335         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7336         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7337         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7338         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7339         call transpose2(AEA(1,1,2),auxmat(1,1))
7340         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7341         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7342         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7343         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7344         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7345         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7346         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7347         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7348         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7349         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7350         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7351 C Calculate the Cartesian derivatives of the vectors.
7352         do iii=1,2
7353           do kkk=1,5
7354             do lll=1,3
7355               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7356               call matvec2(auxmat(1,1),b1(1,iti),
7357      &          AEAb1derx(1,lll,kkk,iii,1,1))
7358               call matvec2(auxmat(1,1),Ub2(1,i),
7359      &          AEAb2derx(1,lll,kkk,iii,1,1))
7360               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7361      &          AEAb1derx(1,lll,kkk,iii,2,1))
7362               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7363      &          AEAb2derx(1,lll,kkk,iii,2,1))
7364               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7365               call matvec2(auxmat(1,1),b1(1,itl),
7366      &          AEAb1derx(1,lll,kkk,iii,1,2))
7367               call matvec2(auxmat(1,1),Ub2(1,l),
7368      &          AEAb2derx(1,lll,kkk,iii,1,2))
7369               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7370      &          AEAb1derx(1,lll,kkk,iii,2,2))
7371               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7372      &          AEAb2derx(1,lll,kkk,iii,2,2))
7373             enddo
7374           enddo
7375         enddo
7376         ENDIF
7377 C End vectors
7378       endif
7379       return
7380       end
7381 C---------------------------------------------------------------------------
7382       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7383      &  KK,KKderg,AKA,AKAderg,AKAderx)
7384       implicit none
7385       integer nderg
7386       logical transp
7387       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7388      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7389      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7390       integer iii,kkk,lll
7391       integer jjj,mmm
7392       logical lprn
7393       common /kutas/ lprn
7394       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7395       do iii=1,nderg
7396         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7397      &    AKAderg(1,1,iii))
7398       enddo
7399 cd      if (lprn) write (2,*) 'In kernel'
7400       do kkk=1,5
7401 cd        if (lprn) write (2,*) 'kkk=',kkk
7402         do lll=1,3
7403           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7404      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7405 cd          if (lprn) then
7406 cd            write (2,*) 'lll=',lll
7407 cd            write (2,*) 'iii=1'
7408 cd            do jjj=1,2
7409 cd              write (2,'(3(2f10.5),5x)')
7410 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7411 cd            enddo
7412 cd          endif
7413           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7414      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7415 cd          if (lprn) then
7416 cd            write (2,*) 'lll=',lll
7417 cd            write (2,*) 'iii=2'
7418 cd            do jjj=1,2
7419 cd              write (2,'(3(2f10.5),5x)')
7420 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7421 cd            enddo
7422 cd          endif
7423         enddo
7424       enddo
7425       return
7426       end
7427 C---------------------------------------------------------------------------
7428       double precision function eello4(i,j,k,l,jj,kk)
7429       implicit real*8 (a-h,o-z)
7430       include 'DIMENSIONS'
7431       include 'sizesclu.dat'
7432       include 'COMMON.IOUNITS'
7433       include 'COMMON.CHAIN'
7434       include 'COMMON.DERIV'
7435       include 'COMMON.INTERACT'
7436       include 'COMMON.CONTACTS'
7437       include 'COMMON.TORSION'
7438       include 'COMMON.VAR'
7439       include 'COMMON.GEO'
7440       double precision pizda(2,2),ggg1(3),ggg2(3)
7441 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7442 cd        eello4=0.0d0
7443 cd        return
7444 cd      endif
7445 cd      print *,'eello4:',i,j,k,l,jj,kk
7446 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7447 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7448 cold      eij=facont_hb(jj,i)
7449 cold      ekl=facont_hb(kk,k)
7450 cold      ekont=eij*ekl
7451       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7452       if (calc_grad) then
7453 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7454       gcorr_loc(k-1)=gcorr_loc(k-1)
7455      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7456       if (l.eq.j+1) then
7457         gcorr_loc(l-1)=gcorr_loc(l-1)
7458      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7459       else
7460         gcorr_loc(j-1)=gcorr_loc(j-1)
7461      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7462       endif
7463       do iii=1,2
7464         do kkk=1,5
7465           do lll=1,3
7466             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7467      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7468 cd            derx(lll,kkk,iii)=0.0d0
7469           enddo
7470         enddo
7471       enddo
7472 cd      gcorr_loc(l-1)=0.0d0
7473 cd      gcorr_loc(j-1)=0.0d0
7474 cd      gcorr_loc(k-1)=0.0d0
7475 cd      eel4=1.0d0
7476 cd      write (iout,*)'Contacts have occurred for peptide groups',
7477 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7478 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7479       if (j.lt.nres-1) then
7480         j1=j+1
7481         j2=j-1
7482       else
7483         j1=j-1
7484         j2=j-2
7485       endif
7486       if (l.lt.nres-1) then
7487         l1=l+1
7488         l2=l-1
7489       else
7490         l1=l-1
7491         l2=l-2
7492       endif
7493       do ll=1,3
7494 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7495         ggg1(ll)=eel4*g_contij(ll,1)
7496         ggg2(ll)=eel4*g_contij(ll,2)
7497         ghalf=0.5d0*ggg1(ll)
7498 cd        ghalf=0.0d0
7499         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7500         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7501         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7502         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7503 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7504         ghalf=0.5d0*ggg2(ll)
7505 cd        ghalf=0.0d0
7506         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7507         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7508         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7509         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7510       enddo
7511 cd      goto 1112
7512       do m=i+1,j-1
7513         do ll=1,3
7514 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7515           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7516         enddo
7517       enddo
7518       do m=k+1,l-1
7519         do ll=1,3
7520 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7521           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7522         enddo
7523       enddo
7524 1112  continue
7525       do m=i+2,j2
7526         do ll=1,3
7527           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7528         enddo
7529       enddo
7530       do m=k+2,l2
7531         do ll=1,3
7532           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7533         enddo
7534       enddo
7535 cd      do iii=1,nres-3
7536 cd        write (2,*) iii,gcorr_loc(iii)
7537 cd      enddo
7538       endif
7539       eello4=ekont*eel4
7540 cd      write (2,*) 'ekont',ekont
7541 cd      write (iout,*) 'eello4',ekont*eel4
7542       return
7543       end
7544 C---------------------------------------------------------------------------
7545       double precision function eello5(i,j,k,l,jj,kk)
7546       implicit real*8 (a-h,o-z)
7547       include 'DIMENSIONS'
7548       include 'sizesclu.dat'
7549       include 'COMMON.IOUNITS'
7550       include 'COMMON.CHAIN'
7551       include 'COMMON.DERIV'
7552       include 'COMMON.INTERACT'
7553       include 'COMMON.CONTACTS'
7554       include 'COMMON.TORSION'
7555       include 'COMMON.VAR'
7556       include 'COMMON.GEO'
7557       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7558       double precision ggg1(3),ggg2(3)
7559 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7560 C                                                                              C
7561 C                            Parallel chains                                   C
7562 C                                                                              C
7563 C          o             o                   o             o                   C
7564 C         /l\           / \             \   / \           / \   /              C
7565 C        /   \         /   \             \ /   \         /   \ /               C
7566 C       j| o |l1       | o |              o| o |         | o |o                C
7567 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7568 C      \i/   \         /   \ /             /   \         /   \                 C
7569 C       o    k1             o                                                  C
7570 C         (I)          (II)                (III)          (IV)                 C
7571 C                                                                              C
7572 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7573 C                                                                              C
7574 C                            Antiparallel chains                               C
7575 C                                                                              C
7576 C          o             o                   o             o                   C
7577 C         /j\           / \             \   / \           / \   /              C
7578 C        /   \         /   \             \ /   \         /   \ /               C
7579 C      j1| o |l        | o |              o| o |         | o |o                C
7580 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7581 C      \i/   \         /   \ /             /   \         /   \                 C
7582 C       o     k1            o                                                  C
7583 C         (I)          (II)                (III)          (IV)                 C
7584 C                                                                              C
7585 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7586 C                                                                              C
7587 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7588 C                                                                              C
7589 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7590 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7591 cd        eello5=0.0d0
7592 cd        return
7593 cd      endif
7594 cd      write (iout,*)
7595 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7596 cd     &   ' and',k,l
7597       itk=itortyp(itype(k))
7598       itl=itortyp(itype(l))
7599       itj=itortyp(itype(j))
7600       eello5_1=0.0d0
7601       eello5_2=0.0d0
7602       eello5_3=0.0d0
7603       eello5_4=0.0d0
7604 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7605 cd     &   eel5_3_num,eel5_4_num)
7606       do iii=1,2
7607         do kkk=1,5
7608           do lll=1,3
7609             derx(lll,kkk,iii)=0.0d0
7610           enddo
7611         enddo
7612       enddo
7613 cd      eij=facont_hb(jj,i)
7614 cd      ekl=facont_hb(kk,k)
7615 cd      ekont=eij*ekl
7616 cd      write (iout,*)'Contacts have occurred for peptide groups',
7617 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7618 cd      goto 1111
7619 C Contribution from the graph I.
7620 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7621 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7622       call transpose2(EUg(1,1,k),auxmat(1,1))
7623       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7624       vv(1)=pizda(1,1)-pizda(2,2)
7625       vv(2)=pizda(1,2)+pizda(2,1)
7626       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7627      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7628       if (calc_grad) then
7629 C Explicit gradient in virtual-dihedral angles.
7630       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7631      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7632      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7633       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7634       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7635       vv(1)=pizda(1,1)-pizda(2,2)
7636       vv(2)=pizda(1,2)+pizda(2,1)
7637       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7638      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7639      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7640       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7641       vv(1)=pizda(1,1)-pizda(2,2)
7642       vv(2)=pizda(1,2)+pizda(2,1)
7643       if (l.eq.j+1) then
7644         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7645      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7646      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7647       else
7648         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7649      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7650      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7651       endif
7652 C Cartesian gradient
7653       do iii=1,2
7654         do kkk=1,5
7655           do lll=1,3
7656             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7657      &        pizda(1,1))
7658             vv(1)=pizda(1,1)-pizda(2,2)
7659             vv(2)=pizda(1,2)+pizda(2,1)
7660             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7661      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7662      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7663           enddo
7664         enddo
7665       enddo
7666 c      goto 1112
7667       endif
7668 c1111  continue
7669 C Contribution from graph II
7670       call transpose2(EE(1,1,itk),auxmat(1,1))
7671       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7672       vv(1)=pizda(1,1)+pizda(2,2)
7673       vv(2)=pizda(2,1)-pizda(1,2)
7674       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7675      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7676       if (calc_grad) then
7677 C Explicit gradient in virtual-dihedral angles.
7678       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7679      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7680       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7681       vv(1)=pizda(1,1)+pizda(2,2)
7682       vv(2)=pizda(2,1)-pizda(1,2)
7683       if (l.eq.j+1) then
7684         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7685      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7686      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7687       else
7688         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7689      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7690      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7691       endif
7692 C Cartesian gradient
7693       do iii=1,2
7694         do kkk=1,5
7695           do lll=1,3
7696             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7697      &        pizda(1,1))
7698             vv(1)=pizda(1,1)+pizda(2,2)
7699             vv(2)=pizda(2,1)-pizda(1,2)
7700             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7701      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7702      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7703           enddo
7704         enddo
7705       enddo
7706 cd      goto 1112
7707       endif
7708 cd1111  continue
7709       if (l.eq.j+1) then
7710 cd        goto 1110
7711 C Parallel orientation
7712 C Contribution from graph III
7713         call transpose2(EUg(1,1,l),auxmat(1,1))
7714         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7715         vv(1)=pizda(1,1)-pizda(2,2)
7716         vv(2)=pizda(1,2)+pizda(2,1)
7717         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7718      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7719         if (calc_grad) then
7720 C Explicit gradient in virtual-dihedral angles.
7721         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7722      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7723      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7724         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7725         vv(1)=pizda(1,1)-pizda(2,2)
7726         vv(2)=pizda(1,2)+pizda(2,1)
7727         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7728      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7729      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7730         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7731         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7732         vv(1)=pizda(1,1)-pizda(2,2)
7733         vv(2)=pizda(1,2)+pizda(2,1)
7734         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7735      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7736      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7737 C Cartesian gradient
7738         do iii=1,2
7739           do kkk=1,5
7740             do lll=1,3
7741               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7742      &          pizda(1,1))
7743               vv(1)=pizda(1,1)-pizda(2,2)
7744               vv(2)=pizda(1,2)+pizda(2,1)
7745               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7746      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7747      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7748             enddo
7749           enddo
7750         enddo
7751 cd        goto 1112
7752         endif
7753 C Contribution from graph IV
7754 cd1110    continue
7755         call transpose2(EE(1,1,itl),auxmat(1,1))
7756         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7757         vv(1)=pizda(1,1)+pizda(2,2)
7758         vv(2)=pizda(2,1)-pizda(1,2)
7759         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7760      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7761         if (calc_grad) then
7762 C Explicit gradient in virtual-dihedral angles.
7763         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7764      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7765         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7766         vv(1)=pizda(1,1)+pizda(2,2)
7767         vv(2)=pizda(2,1)-pizda(1,2)
7768         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7769      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7770      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7771 C Cartesian gradient
7772         do iii=1,2
7773           do kkk=1,5
7774             do lll=1,3
7775               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7776      &          pizda(1,1))
7777               vv(1)=pizda(1,1)+pizda(2,2)
7778               vv(2)=pizda(2,1)-pizda(1,2)
7779               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7780      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7781      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7782             enddo
7783           enddo
7784         enddo
7785         endif
7786       else
7787 C Antiparallel orientation
7788 C Contribution from graph III
7789 c        goto 1110
7790         call transpose2(EUg(1,1,j),auxmat(1,1))
7791         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7792         vv(1)=pizda(1,1)-pizda(2,2)
7793         vv(2)=pizda(1,2)+pizda(2,1)
7794         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7795      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7796         if (calc_grad) then
7797 C Explicit gradient in virtual-dihedral angles.
7798         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7799      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7800      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7801         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7802         vv(1)=pizda(1,1)-pizda(2,2)
7803         vv(2)=pizda(1,2)+pizda(2,1)
7804         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7805      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7806      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7807         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7808         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7809         vv(1)=pizda(1,1)-pizda(2,2)
7810         vv(2)=pizda(1,2)+pizda(2,1)
7811         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7812      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7813      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7814 C Cartesian gradient
7815         do iii=1,2
7816           do kkk=1,5
7817             do lll=1,3
7818               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7819      &          pizda(1,1))
7820               vv(1)=pizda(1,1)-pizda(2,2)
7821               vv(2)=pizda(1,2)+pizda(2,1)
7822               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7823      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7824      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7825             enddo
7826           enddo
7827         enddo
7828 cd        goto 1112
7829         endif
7830 C Contribution from graph IV
7831 1110    continue
7832         call transpose2(EE(1,1,itj),auxmat(1,1))
7833         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7834         vv(1)=pizda(1,1)+pizda(2,2)
7835         vv(2)=pizda(2,1)-pizda(1,2)
7836         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7837      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7838         if (calc_grad) then
7839 C Explicit gradient in virtual-dihedral angles.
7840         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7841      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7842         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7843         vv(1)=pizda(1,1)+pizda(2,2)
7844         vv(2)=pizda(2,1)-pizda(1,2)
7845         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7846      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7847      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7848 C Cartesian gradient
7849         do iii=1,2
7850           do kkk=1,5
7851             do lll=1,3
7852               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7853      &          pizda(1,1))
7854               vv(1)=pizda(1,1)+pizda(2,2)
7855               vv(2)=pizda(2,1)-pizda(1,2)
7856               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7857      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7858      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7859             enddo
7860           enddo
7861         enddo
7862       endif
7863       endif
7864 1112  continue
7865       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7866 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7867 cd        write (2,*) 'ijkl',i,j,k,l
7868 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7869 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7870 cd      endif
7871 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7872 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7873 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7874 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7875       if (calc_grad) then
7876       if (j.lt.nres-1) then
7877         j1=j+1
7878         j2=j-1
7879       else
7880         j1=j-1
7881         j2=j-2
7882       endif
7883       if (l.lt.nres-1) then
7884         l1=l+1
7885         l2=l-1
7886       else
7887         l1=l-1
7888         l2=l-2
7889       endif
7890 cd      eij=1.0d0
7891 cd      ekl=1.0d0
7892 cd      ekont=1.0d0
7893 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7894       do ll=1,3
7895         ggg1(ll)=eel5*g_contij(ll,1)
7896         ggg2(ll)=eel5*g_contij(ll,2)
7897 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7898         ghalf=0.5d0*ggg1(ll)
7899 cd        ghalf=0.0d0
7900         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7901         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7902         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7903         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7904 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7905         ghalf=0.5d0*ggg2(ll)
7906 cd        ghalf=0.0d0
7907         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7908         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7909         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7910         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7911       enddo
7912 cd      goto 1112
7913       do m=i+1,j-1
7914         do ll=1,3
7915 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7916           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7917         enddo
7918       enddo
7919       do m=k+1,l-1
7920         do ll=1,3
7921 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7922           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7923         enddo
7924       enddo
7925 c1112  continue
7926       do m=i+2,j2
7927         do ll=1,3
7928           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7929         enddo
7930       enddo
7931       do m=k+2,l2
7932         do ll=1,3
7933           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7934         enddo
7935       enddo
7936 cd      do iii=1,nres-3
7937 cd        write (2,*) iii,g_corr5_loc(iii)
7938 cd      enddo
7939       endif
7940       eello5=ekont*eel5
7941 cd      write (2,*) 'ekont',ekont
7942 cd      write (iout,*) 'eello5',ekont*eel5
7943       return
7944       end
7945 c--------------------------------------------------------------------------
7946       double precision function eello6(i,j,k,l,jj,kk)
7947       implicit real*8 (a-h,o-z)
7948       include 'DIMENSIONS'
7949       include 'sizesclu.dat'
7950       include 'COMMON.IOUNITS'
7951       include 'COMMON.CHAIN'
7952       include 'COMMON.DERIV'
7953       include 'COMMON.INTERACT'
7954       include 'COMMON.CONTACTS'
7955       include 'COMMON.TORSION'
7956       include 'COMMON.VAR'
7957       include 'COMMON.GEO'
7958       include 'COMMON.FFIELD'
7959       double precision ggg1(3),ggg2(3)
7960 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7961 cd        eello6=0.0d0
7962 cd        return
7963 cd      endif
7964 cd      write (iout,*)
7965 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7966 cd     &   ' and',k,l
7967       eello6_1=0.0d0
7968       eello6_2=0.0d0
7969       eello6_3=0.0d0
7970       eello6_4=0.0d0
7971       eello6_5=0.0d0
7972       eello6_6=0.0d0
7973 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7974 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7975       do iii=1,2
7976         do kkk=1,5
7977           do lll=1,3
7978             derx(lll,kkk,iii)=0.0d0
7979           enddo
7980         enddo
7981       enddo
7982 cd      eij=facont_hb(jj,i)
7983 cd      ekl=facont_hb(kk,k)
7984 cd      ekont=eij*ekl
7985 cd      eij=1.0d0
7986 cd      ekl=1.0d0
7987 cd      ekont=1.0d0
7988       if (l.eq.j+1) then
7989         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7990         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7991         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7992         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7993         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7994         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7995       else
7996         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7997         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7998         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7999         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8000         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8001           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8002         else
8003           eello6_5=0.0d0
8004         endif
8005         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8006       endif
8007 C If turn contributions are considered, they will be handled separately.
8008       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8009 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
8010 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
8011 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
8012 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
8013 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
8014 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
8015 cd      goto 1112
8016       if (calc_grad) then
8017       if (j.lt.nres-1) then
8018         j1=j+1
8019         j2=j-1
8020       else
8021         j1=j-1
8022         j2=j-2
8023       endif
8024       if (l.lt.nres-1) then
8025         l1=l+1
8026         l2=l-1
8027       else
8028         l1=l-1
8029         l2=l-2
8030       endif
8031       do ll=1,3
8032         ggg1(ll)=eel6*g_contij(ll,1)
8033         ggg2(ll)=eel6*g_contij(ll,2)
8034 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8035         ghalf=0.5d0*ggg1(ll)
8036 cd        ghalf=0.0d0
8037         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
8038         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8039         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
8040         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8041         ghalf=0.5d0*ggg2(ll)
8042 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8043 cd        ghalf=0.0d0
8044         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
8045         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8046         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
8047         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8048       enddo
8049 cd      goto 1112
8050       do m=i+1,j-1
8051         do ll=1,3
8052 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8053           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8054         enddo
8055       enddo
8056       do m=k+1,l-1
8057         do ll=1,3
8058 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8059           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8060         enddo
8061       enddo
8062 1112  continue
8063       do m=i+2,j2
8064         do ll=1,3
8065           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8066         enddo
8067       enddo
8068       do m=k+2,l2
8069         do ll=1,3
8070           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8071         enddo
8072       enddo
8073 cd      do iii=1,nres-3
8074 cd        write (2,*) iii,g_corr6_loc(iii)
8075 cd      enddo
8076       endif
8077       eello6=ekont*eel6
8078 cd      write (2,*) 'ekont',ekont
8079 cd      write (iout,*) 'eello6',ekont*eel6
8080       return
8081       end
8082 c--------------------------------------------------------------------------
8083       double precision function eello6_graph1(i,j,k,l,imat,swap)
8084       implicit real*8 (a-h,o-z)
8085       include 'DIMENSIONS'
8086       include 'sizesclu.dat'
8087       include 'COMMON.IOUNITS'
8088       include 'COMMON.CHAIN'
8089       include 'COMMON.DERIV'
8090       include 'COMMON.INTERACT'
8091       include 'COMMON.CONTACTS'
8092       include 'COMMON.TORSION'
8093       include 'COMMON.VAR'
8094       include 'COMMON.GEO'
8095       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8096       logical swap
8097       logical lprn
8098       common /kutas/ lprn
8099 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8100 C                                                                              C
8101 C      Parallel       Antiparallel                                             C
8102 C                                                                              C
8103 C          o             o                                                     C
8104 C         /l\           /j\                                                    C
8105 C        /   \         /   \                                                   C
8106 C       /| o |         | o |\                                                  C
8107 C     \ j|/k\|  /   \  |/k\|l /                                                C
8108 C      \ /   \ /     \ /   \ /                                                 C
8109 C       o     o       o     o                                                  C
8110 C       i             i                                                        C
8111 C                                                                              C
8112 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8113       itk=itortyp(itype(k))
8114       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8115       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8116       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8117       call transpose2(EUgC(1,1,k),auxmat(1,1))
8118       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8119       vv1(1)=pizda1(1,1)-pizda1(2,2)
8120       vv1(2)=pizda1(1,2)+pizda1(2,1)
8121       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8122       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8123       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8124       s5=scalar2(vv(1),Dtobr2(1,i))
8125 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8126       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8127       if (.not. calc_grad) return
8128       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8129      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8130      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8131      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8132      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8133      & +scalar2(vv(1),Dtobr2der(1,i)))
8134       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8135       vv1(1)=pizda1(1,1)-pizda1(2,2)
8136       vv1(2)=pizda1(1,2)+pizda1(2,1)
8137       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8138       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8139       if (l.eq.j+1) then
8140         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8141      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8142      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8143      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8144      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8145       else
8146         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8147      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8148      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8149      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8150      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8151       endif
8152       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8153       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8154       vv1(1)=pizda1(1,1)-pizda1(2,2)
8155       vv1(2)=pizda1(1,2)+pizda1(2,1)
8156       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8157      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8158      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8159      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8160       do iii=1,2
8161         if (swap) then
8162           ind=3-iii
8163         else
8164           ind=iii
8165         endif
8166         do kkk=1,5
8167           do lll=1,3
8168             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8169             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8170             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8171             call transpose2(EUgC(1,1,k),auxmat(1,1))
8172             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8173      &        pizda1(1,1))
8174             vv1(1)=pizda1(1,1)-pizda1(2,2)
8175             vv1(2)=pizda1(1,2)+pizda1(2,1)
8176             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8177             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8178      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8179             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8180      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8181             s5=scalar2(vv(1),Dtobr2(1,i))
8182             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8183           enddo
8184         enddo
8185       enddo
8186       return
8187       end
8188 c----------------------------------------------------------------------------
8189       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8190       implicit real*8 (a-h,o-z)
8191       include 'DIMENSIONS'
8192       include 'sizesclu.dat'
8193       include 'COMMON.IOUNITS'
8194       include 'COMMON.CHAIN'
8195       include 'COMMON.DERIV'
8196       include 'COMMON.INTERACT'
8197       include 'COMMON.CONTACTS'
8198       include 'COMMON.TORSION'
8199       include 'COMMON.VAR'
8200       include 'COMMON.GEO'
8201       logical swap
8202       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8203      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8204       logical lprn
8205       common /kutas/ lprn
8206 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8207 C                                                                              C
8208 C      Parallel       Antiparallel                                             C
8209 C                                                                              C
8210 C          o             o                                                     C
8211 C     \   /l\           /j\   /                                                C
8212 C      \ /   \         /   \ /                                                 C
8213 C       o| o |         | o |o                                                  C
8214 C     \ j|/k\|      \  |/k\|l                                                  C
8215 C      \ /   \       \ /   \                                                   C
8216 C       o             o                                                        C
8217 C       i             i                                                        C
8218 C                                                                              C
8219 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8220 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8221 C AL 7/4/01 s1 would occur in the sixth-order moment,
8222 C           but not in a cluster cumulant
8223 #ifdef MOMENT
8224       s1=dip(1,jj,i)*dip(1,kk,k)
8225 #endif
8226       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8227       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8228       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8229       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8230       call transpose2(EUg(1,1,k),auxmat(1,1))
8231       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8232       vv(1)=pizda(1,1)-pizda(2,2)
8233       vv(2)=pizda(1,2)+pizda(2,1)
8234       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8235 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8236 #ifdef MOMENT
8237       eello6_graph2=-(s1+s2+s3+s4)
8238 #else
8239       eello6_graph2=-(s2+s3+s4)
8240 #endif
8241 c      eello6_graph2=-s3
8242       if (.not. calc_grad) return
8243 C Derivatives in gamma(i-1)
8244       if (i.gt.1) then
8245 #ifdef MOMENT
8246         s1=dipderg(1,jj,i)*dip(1,kk,k)
8247 #endif
8248         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8249         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8250         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8251         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8252 #ifdef MOMENT
8253         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8254 #else
8255         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8256 #endif
8257 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8258       endif
8259 C Derivatives in gamma(k-1)
8260 #ifdef MOMENT
8261       s1=dip(1,jj,i)*dipderg(1,kk,k)
8262 #endif
8263       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8264       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8265       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8266       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8267       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8268       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8269       vv(1)=pizda(1,1)-pizda(2,2)
8270       vv(2)=pizda(1,2)+pizda(2,1)
8271       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8272 #ifdef MOMENT
8273       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8274 #else
8275       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8276 #endif
8277 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8278 C Derivatives in gamma(j-1) or gamma(l-1)
8279       if (j.gt.1) then
8280 #ifdef MOMENT
8281         s1=dipderg(3,jj,i)*dip(1,kk,k)
8282 #endif
8283         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8284         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8285         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8286         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8287         vv(1)=pizda(1,1)-pizda(2,2)
8288         vv(2)=pizda(1,2)+pizda(2,1)
8289         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8290 #ifdef MOMENT
8291         if (swap) then
8292           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8293         else
8294           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8295         endif
8296 #endif
8297         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8298 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8299       endif
8300 C Derivatives in gamma(l-1) or gamma(j-1)
8301       if (l.gt.1) then
8302 #ifdef MOMENT
8303         s1=dip(1,jj,i)*dipderg(3,kk,k)
8304 #endif
8305         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8306         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8307         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8308         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8309         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8310         vv(1)=pizda(1,1)-pizda(2,2)
8311         vv(2)=pizda(1,2)+pizda(2,1)
8312         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8313 #ifdef MOMENT
8314         if (swap) then
8315           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8316         else
8317           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8318         endif
8319 #endif
8320         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8321 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8322       endif
8323 C Cartesian derivatives.
8324       if (lprn) then
8325         write (2,*) 'In eello6_graph2'
8326         do iii=1,2
8327           write (2,*) 'iii=',iii
8328           do kkk=1,5
8329             write (2,*) 'kkk=',kkk
8330             do jjj=1,2
8331               write (2,'(3(2f10.5),5x)')
8332      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8333             enddo
8334           enddo
8335         enddo
8336       endif
8337       do iii=1,2
8338         do kkk=1,5
8339           do lll=1,3
8340 #ifdef MOMENT
8341             if (iii.eq.1) then
8342               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8343             else
8344               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8345             endif
8346 #endif
8347             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8348      &        auxvec(1))
8349             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8350             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8351      &        auxvec(1))
8352             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8353             call transpose2(EUg(1,1,k),auxmat(1,1))
8354             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8355      &        pizda(1,1))
8356             vv(1)=pizda(1,1)-pizda(2,2)
8357             vv(2)=pizda(1,2)+pizda(2,1)
8358             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8359 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8360 #ifdef MOMENT
8361             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8362 #else
8363             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8364 #endif
8365             if (swap) then
8366               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8367             else
8368               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8369             endif
8370           enddo
8371         enddo
8372       enddo
8373       return
8374       end
8375 c----------------------------------------------------------------------------
8376       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8377       implicit real*8 (a-h,o-z)
8378       include 'DIMENSIONS'
8379       include 'sizesclu.dat'
8380       include 'COMMON.IOUNITS'
8381       include 'COMMON.CHAIN'
8382       include 'COMMON.DERIV'
8383       include 'COMMON.INTERACT'
8384       include 'COMMON.CONTACTS'
8385       include 'COMMON.TORSION'
8386       include 'COMMON.VAR'
8387       include 'COMMON.GEO'
8388       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8389       logical swap
8390 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8391 C                                                                              C
8392 C      Parallel       Antiparallel                                             C
8393 C                                                                              C
8394 C          o             o                                                     C
8395 C         /l\   /   \   /j\                                                    C
8396 C        /   \ /     \ /   \                                                   C
8397 C       /| o |o       o| o |\                                                  C
8398 C       j|/k\|  /      |/k\|l /                                                C
8399 C        /   \ /       /   \ /                                                 C
8400 C       /     o       /     o                                                  C
8401 C       i             i                                                        C
8402 C                                                                              C
8403 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8404 C
8405 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8406 C           energy moment and not to the cluster cumulant.
8407       iti=itortyp(itype(i))
8408 c      if (j.lt.nres-1) then
8409       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
8410         itj1=itortyp(itype(j+1))
8411       else
8412         itj1=ntortyp+1
8413       endif
8414       itk=itortyp(itype(k))
8415       itk1=itortyp(itype(k+1))
8416 c      if (l.lt.nres-1) then
8417       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
8418         itl1=itortyp(itype(l+1))
8419       else
8420         itl1=ntortyp+1
8421       endif
8422 #ifdef MOMENT
8423       s1=dip(4,jj,i)*dip(4,kk,k)
8424 #endif
8425       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8426       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8427       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8428       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8429       call transpose2(EE(1,1,itk),auxmat(1,1))
8430       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8431       vv(1)=pizda(1,1)+pizda(2,2)
8432       vv(2)=pizda(2,1)-pizda(1,2)
8433       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8434 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8435 #ifdef MOMENT
8436       eello6_graph3=-(s1+s2+s3+s4)
8437 #else
8438       eello6_graph3=-(s2+s3+s4)
8439 #endif
8440 c      eello6_graph3=-s4
8441       if (.not. calc_grad) return
8442 C Derivatives in gamma(k-1)
8443       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8444       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8445       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8446       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8447 C Derivatives in gamma(l-1)
8448       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8449       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8450       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8451       vv(1)=pizda(1,1)+pizda(2,2)
8452       vv(2)=pizda(2,1)-pizda(1,2)
8453       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8454       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8455 C Cartesian derivatives.
8456       do iii=1,2
8457         do kkk=1,5
8458           do lll=1,3
8459 #ifdef MOMENT
8460             if (iii.eq.1) then
8461               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8462             else
8463               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8464             endif
8465 #endif
8466             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8467      &        auxvec(1))
8468             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8469             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8470      &        auxvec(1))
8471             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8472             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8473      &        pizda(1,1))
8474             vv(1)=pizda(1,1)+pizda(2,2)
8475             vv(2)=pizda(2,1)-pizda(1,2)
8476             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8477 #ifdef MOMENT
8478             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8479 #else
8480             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8481 #endif
8482             if (swap) then
8483               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8484             else
8485               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8486             endif
8487 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8488           enddo
8489         enddo
8490       enddo
8491       return
8492       end
8493 c----------------------------------------------------------------------------
8494       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8495       implicit real*8 (a-h,o-z)
8496       include 'DIMENSIONS'
8497       include 'sizesclu.dat'
8498       include 'COMMON.IOUNITS'
8499       include 'COMMON.CHAIN'
8500       include 'COMMON.DERIV'
8501       include 'COMMON.INTERACT'
8502       include 'COMMON.CONTACTS'
8503       include 'COMMON.TORSION'
8504       include 'COMMON.VAR'
8505       include 'COMMON.GEO'
8506       include 'COMMON.FFIELD'
8507       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8508      & auxvec1(2),auxmat1(2,2)
8509       logical swap
8510 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8511 C                                                                              C
8512 C      Parallel       Antiparallel                                             C
8513 C                                                                              C
8514 C          o             o                                                     C
8515 C         /l\   /   \   /j\                                                    C
8516 C        /   \ /     \ /   \                                                   C
8517 C       /| o |o       o| o |\                                                  C
8518 C     \ j|/k\|      \  |/k\|l                                                  C
8519 C      \ /   \       \ /   \                                                   C
8520 C       o     \       o     \                                                  C
8521 C       i             i                                                        C
8522 C                                                                              C
8523 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8524 C
8525 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8526 C           energy moment and not to the cluster cumulant.
8527 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8528       iti=itortyp(itype(i))
8529       itj=itortyp(itype(j))
8530 c      if (j.lt.nres-1) then
8531       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
8532         itj1=itortyp(itype(j+1))
8533       else
8534         itj1=ntortyp+1
8535       endif
8536       itk=itortyp(itype(k))
8537 c      if (k.lt.nres-1) then
8538       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
8539         itk1=itortyp(itype(k+1))
8540       else
8541         itk1=ntortyp+1
8542       endif
8543       itl=itortyp(itype(l))
8544       if (l.lt.nres-1) then
8545         itl1=itortyp(itype(l+1))
8546       else
8547         itl1=ntortyp+1
8548       endif
8549 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8550 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8551 cd     & ' itl',itl,' itl1',itl1
8552 #ifdef MOMENT
8553       if (imat.eq.1) then
8554         s1=dip(3,jj,i)*dip(3,kk,k)
8555       else
8556         s1=dip(2,jj,j)*dip(2,kk,l)
8557       endif
8558 #endif
8559       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8560       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8561       if (j.eq.l+1) then
8562         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8563         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8564       else
8565         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8566         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8567       endif
8568       call transpose2(EUg(1,1,k),auxmat(1,1))
8569       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8570       vv(1)=pizda(1,1)-pizda(2,2)
8571       vv(2)=pizda(2,1)+pizda(1,2)
8572       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8573 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8574 #ifdef MOMENT
8575       eello6_graph4=-(s1+s2+s3+s4)
8576 #else
8577       eello6_graph4=-(s2+s3+s4)
8578 #endif
8579       if (.not. calc_grad) return
8580 C Derivatives in gamma(i-1)
8581       if (i.gt.1) then
8582 #ifdef MOMENT
8583         if (imat.eq.1) then
8584           s1=dipderg(2,jj,i)*dip(3,kk,k)
8585         else
8586           s1=dipderg(4,jj,j)*dip(2,kk,l)
8587         endif
8588 #endif
8589         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8590         if (j.eq.l+1) then
8591           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8592           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8593         else
8594           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8595           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8596         endif
8597         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8598         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8599 cd          write (2,*) 'turn6 derivatives'
8600 #ifdef MOMENT
8601           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8602 #else
8603           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8604 #endif
8605         else
8606 #ifdef MOMENT
8607           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8608 #else
8609           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8610 #endif
8611         endif
8612       endif
8613 C Derivatives in gamma(k-1)
8614 #ifdef MOMENT
8615       if (imat.eq.1) then
8616         s1=dip(3,jj,i)*dipderg(2,kk,k)
8617       else
8618         s1=dip(2,jj,j)*dipderg(4,kk,l)
8619       endif
8620 #endif
8621       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8622       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8623       if (j.eq.l+1) then
8624         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8625         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8626       else
8627         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8628         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8629       endif
8630       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8631       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8632       vv(1)=pizda(1,1)-pizda(2,2)
8633       vv(2)=pizda(2,1)+pizda(1,2)
8634       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8635       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8636 #ifdef MOMENT
8637         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8638 #else
8639         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8640 #endif
8641       else
8642 #ifdef MOMENT
8643         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8644 #else
8645         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8646 #endif
8647       endif
8648 C Derivatives in gamma(j-1) or gamma(l-1)
8649       if (l.eq.j+1 .and. l.gt.1) then
8650         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8651         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8652         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8653         vv(1)=pizda(1,1)-pizda(2,2)
8654         vv(2)=pizda(2,1)+pizda(1,2)
8655         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8656         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8657       else if (j.gt.1) then
8658         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8659         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8660         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8661         vv(1)=pizda(1,1)-pizda(2,2)
8662         vv(2)=pizda(2,1)+pizda(1,2)
8663         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8664         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8665           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8666         else
8667           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8668         endif
8669       endif
8670 C Cartesian derivatives.
8671       do iii=1,2
8672         do kkk=1,5
8673           do lll=1,3
8674 #ifdef MOMENT
8675             if (iii.eq.1) then
8676               if (imat.eq.1) then
8677                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8678               else
8679                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8680               endif
8681             else
8682               if (imat.eq.1) then
8683                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8684               else
8685                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8686               endif
8687             endif
8688 #endif
8689             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8690      &        auxvec(1))
8691             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8692             if (j.eq.l+1) then
8693               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8694      &          b1(1,itj1),auxvec(1))
8695               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8696             else
8697               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8698      &          b1(1,itl1),auxvec(1))
8699               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8700             endif
8701             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8702      &        pizda(1,1))
8703             vv(1)=pizda(1,1)-pizda(2,2)
8704             vv(2)=pizda(2,1)+pizda(1,2)
8705             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8706             if (swap) then
8707               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8708 #ifdef MOMENT
8709                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8710      &             -(s1+s2+s4)
8711 #else
8712                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8713      &             -(s2+s4)
8714 #endif
8715                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8716               else
8717 #ifdef MOMENT
8718                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8719 #else
8720                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8721 #endif
8722                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8723               endif
8724             else
8725 #ifdef MOMENT
8726               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8727 #else
8728               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8729 #endif
8730               if (l.eq.j+1) then
8731                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8732               else
8733                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8734               endif
8735             endif
8736           enddo
8737         enddo
8738       enddo
8739       return
8740       end
8741 c----------------------------------------------------------------------------
8742       double precision function eello_turn6(i,jj,kk)
8743       implicit real*8 (a-h,o-z)
8744       include 'DIMENSIONS'
8745       include 'sizesclu.dat'
8746       include 'COMMON.IOUNITS'
8747       include 'COMMON.CHAIN'
8748       include 'COMMON.DERIV'
8749       include 'COMMON.INTERACT'
8750       include 'COMMON.CONTACTS'
8751       include 'COMMON.TORSION'
8752       include 'COMMON.VAR'
8753       include 'COMMON.GEO'
8754       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8755      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8756      &  ggg1(3),ggg2(3)
8757       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8758      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8759 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8760 C           the respective energy moment and not to the cluster cumulant.
8761       eello_turn6=0.0d0
8762       j=i+4
8763       k=i+1
8764       l=i+3
8765       iti=itortyp(itype(i))
8766       itk=itortyp(itype(k))
8767       itk1=itortyp(itype(k+1))
8768       itl=itortyp(itype(l))
8769       itj=itortyp(itype(j))
8770 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8771 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8772 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8773 cd        eello6=0.0d0
8774 cd        return
8775 cd      endif
8776 cd      write (iout,*)
8777 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8778 cd     &   ' and',k,l
8779 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8780       do iii=1,2
8781         do kkk=1,5
8782           do lll=1,3
8783             derx_turn(lll,kkk,iii)=0.0d0
8784           enddo
8785         enddo
8786       enddo
8787 cd      eij=1.0d0
8788 cd      ekl=1.0d0
8789 cd      ekont=1.0d0
8790       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8791 cd      eello6_5=0.0d0
8792 cd      write (2,*) 'eello6_5',eello6_5
8793 #ifdef MOMENT
8794       call transpose2(AEA(1,1,1),auxmat(1,1))
8795       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8796       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8797       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8798 #else
8799       s1 = 0.0d0
8800 #endif
8801       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8802       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8803       s2 = scalar2(b1(1,itk),vtemp1(1))
8804 #ifdef MOMENT
8805       call transpose2(AEA(1,1,2),atemp(1,1))
8806       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8807       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8808       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8809 #else
8810       s8=0.0d0
8811 #endif
8812       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8813       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8814       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8815 #ifdef MOMENT
8816       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8817       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8818       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8819       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8820       ss13 = scalar2(b1(1,itk),vtemp4(1))
8821       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8822 #else
8823       s13=0.0d0
8824 #endif
8825 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8826 c      s1=0.0d0
8827 c      s2=0.0d0
8828 c      s8=0.0d0
8829 c      s12=0.0d0
8830 c      s13=0.0d0
8831       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8832       if (calc_grad) then
8833 C Derivatives in gamma(i+2)
8834 #ifdef MOMENT
8835       call transpose2(AEA(1,1,1),auxmatd(1,1))
8836       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8837       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8838       call transpose2(AEAderg(1,1,2),atempd(1,1))
8839       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8840       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8841 #else
8842       s8d=0.0d0
8843 #endif
8844       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8845       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8846       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8847 c      s1d=0.0d0
8848 c      s2d=0.0d0
8849 c      s8d=0.0d0
8850 c      s12d=0.0d0
8851 c      s13d=0.0d0
8852       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8853 C Derivatives in gamma(i+3)
8854 #ifdef MOMENT
8855       call transpose2(AEA(1,1,1),auxmatd(1,1))
8856       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8857       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8858       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8859 #else
8860       s1d=0.0d0
8861 #endif
8862       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8863       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8864       s2d = scalar2(b1(1,itk),vtemp1d(1))
8865 #ifdef MOMENT
8866       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8867       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8868 #endif
8869       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8870 #ifdef MOMENT
8871       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8872       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8873       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8874 #else
8875       s13d=0.0d0
8876 #endif
8877 c      s1d=0.0d0
8878 c      s2d=0.0d0
8879 c      s8d=0.0d0
8880 c      s12d=0.0d0
8881 c      s13d=0.0d0
8882 #ifdef MOMENT
8883       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8884      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8885 #else
8886       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8887      &               -0.5d0*ekont*(s2d+s12d)
8888 #endif
8889 C Derivatives in gamma(i+4)
8890       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8891       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8892       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8893 #ifdef MOMENT
8894       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8895       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8896       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8897 #else
8898       s13d = 0.0d0
8899 #endif
8900 c      s1d=0.0d0
8901 c      s2d=0.0d0
8902 c      s8d=0.0d0
8903 C      s12d=0.0d0
8904 c      s13d=0.0d0
8905 #ifdef MOMENT
8906       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8907 #else
8908       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8909 #endif
8910 C Derivatives in gamma(i+5)
8911 #ifdef MOMENT
8912       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8913       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8914       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8915 #else
8916       s1d = 0.0d0
8917 #endif
8918       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8919       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8920       s2d = scalar2(b1(1,itk),vtemp1d(1))
8921 #ifdef MOMENT
8922       call transpose2(AEA(1,1,2),atempd(1,1))
8923       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8924       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8925 #else
8926       s8d = 0.0d0
8927 #endif
8928       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8929       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8930 #ifdef MOMENT
8931       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8932       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8933       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8934 #else
8935       s13d = 0.0d0
8936 #endif
8937 c      s1d=0.0d0
8938 c      s2d=0.0d0
8939 c      s8d=0.0d0
8940 c      s12d=0.0d0
8941 c      s13d=0.0d0
8942 #ifdef MOMENT
8943       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8944      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8945 #else
8946       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8947      &               -0.5d0*ekont*(s2d+s12d)
8948 #endif
8949 C Cartesian derivatives
8950       do iii=1,2
8951         do kkk=1,5
8952           do lll=1,3
8953 #ifdef MOMENT
8954             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8955             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8956             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8957 #else
8958             s1d = 0.0d0
8959 #endif
8960             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8961             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8962      &          vtemp1d(1))
8963             s2d = scalar2(b1(1,itk),vtemp1d(1))
8964 #ifdef MOMENT
8965             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8966             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8967             s8d = -(atempd(1,1)+atempd(2,2))*
8968      &           scalar2(cc(1,1,itl),vtemp2(1))
8969 #else
8970             s8d = 0.0d0
8971 #endif
8972             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8973      &           auxmatd(1,1))
8974             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8975             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8976 c      s1d=0.0d0
8977 c      s2d=0.0d0
8978 c      s8d=0.0d0
8979 c      s12d=0.0d0
8980 c      s13d=0.0d0
8981 #ifdef MOMENT
8982             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8983      &        - 0.5d0*(s1d+s2d)
8984 #else
8985             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8986      &        - 0.5d0*s2d
8987 #endif
8988 #ifdef MOMENT
8989             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8990      &        - 0.5d0*(s8d+s12d)
8991 #else
8992             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8993      &        - 0.5d0*s12d
8994 #endif
8995           enddo
8996         enddo
8997       enddo
8998 #ifdef MOMENT
8999       do kkk=1,5
9000         do lll=1,3
9001           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9002      &      achuj_tempd(1,1))
9003           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9004           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9005           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9006           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9007           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9008      &      vtemp4d(1))
9009           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9010           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9011           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9012         enddo
9013       enddo
9014 #endif
9015 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9016 cd     &  16*eel_turn6_num
9017 cd      goto 1112
9018       if (j.lt.nres-1) then
9019         j1=j+1
9020         j2=j-1
9021       else
9022         j1=j-1
9023         j2=j-2
9024       endif
9025       if (l.lt.nres-1) then
9026         l1=l+1
9027         l2=l-1
9028       else
9029         l1=l-1
9030         l2=l-2
9031       endif
9032       do ll=1,3
9033         ggg1(ll)=eel_turn6*g_contij(ll,1)
9034         ggg2(ll)=eel_turn6*g_contij(ll,2)
9035         ghalf=0.5d0*ggg1(ll)
9036 cd        ghalf=0.0d0
9037         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
9038      &    +ekont*derx_turn(ll,2,1)
9039         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9040         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
9041      &    +ekont*derx_turn(ll,4,1)
9042         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9043         ghalf=0.5d0*ggg2(ll)
9044 cd        ghalf=0.0d0
9045         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
9046      &    +ekont*derx_turn(ll,2,2)
9047         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9048         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
9049      &    +ekont*derx_turn(ll,4,2)
9050         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9051       enddo
9052 cd      goto 1112
9053       do m=i+1,j-1
9054         do ll=1,3
9055           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9056         enddo
9057       enddo
9058       do m=k+1,l-1
9059         do ll=1,3
9060           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9061         enddo
9062       enddo
9063 1112  continue
9064       do m=i+2,j2
9065         do ll=1,3
9066           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9067         enddo
9068       enddo
9069       do m=k+2,l2
9070         do ll=1,3
9071           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9072         enddo
9073       enddo
9074 cd      do iii=1,nres-3
9075 cd        write (2,*) iii,g_corr6_loc(iii)
9076 cd      enddo
9077       endif
9078       eello_turn6=ekont*eel_turn6
9079 cd      write (2,*) 'ekont',ekont
9080 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9081       return
9082       end
9083 crc-------------------------------------------------
9084       SUBROUTINE MATVEC2(A1,V1,V2)
9085       implicit real*8 (a-h,o-z)
9086       include 'DIMENSIONS'
9087       DIMENSION A1(2,2),V1(2),V2(2)
9088 c      DO 1 I=1,2
9089 c        VI=0.0
9090 c        DO 3 K=1,2
9091 c    3     VI=VI+A1(I,K)*V1(K)
9092 c        Vaux(I)=VI
9093 c    1 CONTINUE
9094
9095       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9096       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9097
9098       v2(1)=vaux1
9099       v2(2)=vaux2
9100       END
9101 C---------------------------------------
9102       SUBROUTINE MATMAT2(A1,A2,A3)
9103       implicit real*8 (a-h,o-z)
9104       include 'DIMENSIONS'
9105       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9106 c      DIMENSION AI3(2,2)
9107 c        DO  J=1,2
9108 c          A3IJ=0.0
9109 c          DO K=1,2
9110 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9111 c          enddo
9112 c          A3(I,J)=A3IJ
9113 c       enddo
9114 c      enddo
9115
9116       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9117       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9118       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9119       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9120
9121       A3(1,1)=AI3_11
9122       A3(2,1)=AI3_21
9123       A3(1,2)=AI3_12
9124       A3(2,2)=AI3_22
9125       END
9126
9127 c-------------------------------------------------------------------------
9128       double precision function scalar2(u,v)
9129       implicit none
9130       double precision u(2),v(2)
9131       double precision sc
9132       integer i
9133       scalar2=u(1)*v(1)+u(2)*v(2)
9134       return
9135       end
9136
9137 C-----------------------------------------------------------------------------
9138
9139       subroutine transpose2(a,at)
9140       implicit none
9141       double precision a(2,2),at(2,2)
9142       at(1,1)=a(1,1)
9143       at(1,2)=a(2,1)
9144       at(2,1)=a(1,2)
9145       at(2,2)=a(2,2)
9146       return
9147       end
9148 c--------------------------------------------------------------------------
9149       subroutine transpose(n,a,at)
9150       implicit none
9151       integer n,i,j
9152       double precision a(n,n),at(n,n)
9153       do i=1,n
9154         do j=1,n
9155           at(j,i)=a(i,j)
9156         enddo
9157       enddo
9158       return
9159       end
9160 C---------------------------------------------------------------------------
9161       subroutine prodmat3(a1,a2,kk,transp,prod)
9162       implicit none
9163       integer i,j
9164       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9165       logical transp
9166 crc      double precision auxmat(2,2),prod_(2,2)
9167
9168       if (transp) then
9169 crc        call transpose2(kk(1,1),auxmat(1,1))
9170 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9171 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9172
9173            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9174      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9175            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9176      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9177            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9178      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9179            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9180      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9181
9182       else
9183 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9184 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9185
9186            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9187      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9188            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9189      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9190            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9191      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9192            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9193      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9194
9195       endif
9196 c      call transpose2(a2(1,1),a2t(1,1))
9197
9198 crc      print *,transp
9199 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9200 crc      print *,((prod(i,j),i=1,2),j=1,2)
9201
9202       return
9203       end
9204 C-----------------------------------------------------------------------------
9205       double precision function scalar(u,v)
9206       implicit none
9207       double precision u(3),v(3)
9208       double precision sc
9209       integer i
9210       sc=0.0d0
9211       do i=1,3
9212         sc=sc+u(i)*v(i)
9213       enddo
9214       scalar=sc
9215       return
9216       end
9217 C-----------------------------------------------------------------------
9218       double precision function sscale(r)
9219       double precision r,gamm
9220       include "COMMON.SPLITELE"
9221       if(r.lt.r_cut-rlamb) then
9222         sscale=1.0d0
9223       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9224         gamm=(r-(r_cut-rlamb))/rlamb
9225         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9226       else
9227         sscale=0d0
9228       endif
9229       return
9230       end
9231 C-----------------------------------------------------------------------
9232 C-----------------------------------------------------------------------
9233       double precision function sscagrad(r)
9234       double precision r,gamm
9235       include "COMMON.SPLITELE"
9236       if(r.lt.r_cut-rlamb) then
9237         sscagrad=0.0d0
9238       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9239         gamm=(r-(r_cut-rlamb))/rlamb
9240         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9241       else
9242         sscagrad=0.0d0
9243       endif
9244       return
9245       end
9246 C-----------------------------------------------------------------------
9247 C first for shielding is setting of function of side-chains
9248        subroutine set_shield_fac2
9249       implicit real*8 (a-h,o-z)
9250       include 'DIMENSIONS'
9251       include 'COMMON.CHAIN'
9252       include 'COMMON.DERIV'
9253       include 'COMMON.IOUNITS'
9254       include 'COMMON.SHIELD'
9255       include 'COMMON.INTERACT'
9256 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9257       double precision div77_81/0.974996043d0/,
9258      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9259
9260 C the vector between center of side_chain and peptide group
9261        double precision pep_side(3),long,side_calf(3),
9262      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9263      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9264 C the line belowe needs to be changed for FGPROC>1
9265       do i=1,nres-1
9266       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9267       ishield_list(i)=0
9268 Cif there two consequtive dummy atoms there is no peptide group between them
9269 C the line below has to be changed for FGPROC>1
9270       VolumeTotal=0.0
9271       do k=1,nres
9272        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9273        dist_pep_side=0.0
9274        dist_side_calf=0.0
9275        do j=1,3
9276 C first lets set vector conecting the ithe side-chain with kth side-chain
9277       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9278 C      pep_side(j)=2.0d0
9279 C and vector conecting the side-chain with its proper calfa
9280       side_calf(j)=c(j,k+nres)-c(j,k)
9281 C      side_calf(j)=2.0d0
9282       pept_group(j)=c(j,i)-c(j,i+1)
9283 C lets have their lenght
9284       dist_pep_side=pep_side(j)**2+dist_pep_side
9285       dist_side_calf=dist_side_calf+side_calf(j)**2
9286       dist_pept_group=dist_pept_group+pept_group(j)**2
9287       enddo
9288        dist_pep_side=dsqrt(dist_pep_side)
9289        dist_pept_group=dsqrt(dist_pept_group)
9290        dist_side_calf=dsqrt(dist_side_calf)
9291       do j=1,3
9292         pep_side_norm(j)=pep_side(j)/dist_pep_side
9293         side_calf_norm(j)=dist_side_calf
9294       enddo
9295 C now sscale fraction
9296        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9297 C       print *,buff_shield,"buff"
9298 C now sscale
9299         if (sh_frac_dist.le.0.0) cycle
9300 C If we reach here it means that this side chain reaches the shielding sphere
9301 C Lets add him to the list for gradient
9302         ishield_list(i)=ishield_list(i)+1
9303 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9304 C this list is essential otherwise problem would be O3
9305         shield_list(ishield_list(i),i)=k
9306 C Lets have the sscale value
9307         if (sh_frac_dist.gt.1.0) then
9308          scale_fac_dist=1.0d0
9309          do j=1,3
9310          sh_frac_dist_grad(j)=0.0d0
9311          enddo
9312         else
9313          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9314      &                   *(2.0d0*sh_frac_dist-3.0d0)
9315          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9316      &                  /dist_pep_side/buff_shield*0.5d0
9317 C remember for the final gradient multiply sh_frac_dist_grad(j)
9318 C for side_chain by factor -2 !
9319          do j=1,3
9320          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9321 C         sh_frac_dist_grad(j)=0.0d0
9322 C         scale_fac_dist=1.0d0
9323 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9324 C     &                    sh_frac_dist_grad(j)
9325          enddo
9326         endif
9327 C this is what is now we have the distance scaling now volume...
9328       short=short_r_sidechain(itype(k))
9329       long=long_r_sidechain(itype(k))
9330       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9331       sinthet=short/dist_pep_side*costhet
9332 C now costhet_grad
9333 C       costhet=0.6d0
9334 C       sinthet=0.8
9335        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9336 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9337 C     &             -short/dist_pep_side**2/costhet)
9338 C       costhet_fac=0.0d0
9339        do j=1,3
9340          costhet_grad(j)=costhet_fac*pep_side(j)
9341        enddo
9342 C remember for the final gradient multiply costhet_grad(j)
9343 C for side_chain by factor -2 !
9344 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9345 C pep_side0pept_group is vector multiplication
9346       pep_side0pept_group=0.0d0
9347       do j=1,3
9348       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9349       enddo
9350       cosalfa=(pep_side0pept_group/
9351      & (dist_pep_side*dist_side_calf))
9352       fac_alfa_sin=1.0d0-cosalfa**2
9353       fac_alfa_sin=dsqrt(fac_alfa_sin)
9354       rkprim=fac_alfa_sin*(long-short)+short
9355 C      rkprim=short
9356
9357 C now costhet_grad
9358        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9359 C       cosphi=0.6
9360        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9361        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9362      &      dist_pep_side**2)
9363 C       sinphi=0.8
9364        do j=1,3
9365          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9366      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9367      &*(long-short)/fac_alfa_sin*cosalfa/
9368      &((dist_pep_side*dist_side_calf))*
9369      &((side_calf(j))-cosalfa*
9370      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9371 C       cosphi_grad_long(j)=0.0d0
9372         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9373      &*(long-short)/fac_alfa_sin*cosalfa
9374      &/((dist_pep_side*dist_side_calf))*
9375      &(pep_side(j)-
9376      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9377 C       cosphi_grad_loc(j)=0.0d0
9378        enddo
9379 C      print *,sinphi,sinthet
9380       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9381      &                    /VSolvSphere_div
9382 C     &                    *wshield
9383 C now the gradient...
9384       do j=1,3
9385       grad_shield(j,i)=grad_shield(j,i)
9386 C gradient po skalowaniu
9387      &                +(sh_frac_dist_grad(j)*VofOverlap
9388 C  gradient po costhet
9389      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9390      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9391      &       sinphi/sinthet*costhet*costhet_grad(j)
9392      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9393      & )*wshield
9394 C grad_shield_side is Cbeta sidechain gradient
9395       grad_shield_side(j,ishield_list(i),i)=
9396      &        (sh_frac_dist_grad(j)*(-2.0d0)
9397      &        *VofOverlap
9398      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9399      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9400      &       sinphi/sinthet*costhet*costhet_grad(j)
9401      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9402      &       )*wshield
9403
9404        grad_shield_loc(j,ishield_list(i),i)=
9405      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9406      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9407      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9408      &        ))
9409      &        *wshield
9410       enddo
9411       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9412       enddo
9413       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9414 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9415       enddo
9416       return
9417       end
9418 C first for shielding is setting of function of side-chains
9419        subroutine set_shield_fac
9420       implicit real*8 (a-h,o-z)
9421       include 'DIMENSIONS'
9422       include 'COMMON.CHAIN'
9423       include 'COMMON.DERIV'
9424       include 'COMMON.IOUNITS'
9425       include 'COMMON.SHIELD'
9426       include 'COMMON.INTERACT'
9427 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9428       double precision div77_81/0.974996043d0/,
9429      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9430
9431 C the vector between center of side_chain and peptide group
9432        double precision pep_side(3),long,side_calf(3),
9433      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9434      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9435 C the line belowe needs to be changed for FGPROC>1
9436       do i=1,nres-1
9437       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9438       ishield_list(i)=0
9439 Cif there two consequtive dummy atoms there is no peptide group between them
9440 C the line below has to be changed for FGPROC>1
9441       VolumeTotal=0.0
9442       do k=1,nres
9443        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9444        dist_pep_side=0.0
9445        dist_side_calf=0.0
9446        do j=1,3
9447 C first lets set vector conecting the ithe side-chain with kth side-chain
9448       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9449 C      pep_side(j)=2.0d0
9450 C and vector conecting the side-chain with its proper calfa
9451       side_calf(j)=c(j,k+nres)-c(j,k)
9452 C      side_calf(j)=2.0d0
9453       pept_group(j)=c(j,i)-c(j,i+1)
9454 C lets have their lenght
9455       dist_pep_side=pep_side(j)**2+dist_pep_side
9456       dist_side_calf=dist_side_calf+side_calf(j)**2
9457       dist_pept_group=dist_pept_group+pept_group(j)**2
9458       enddo
9459        dist_pep_side=dsqrt(dist_pep_side)
9460        dist_pept_group=dsqrt(dist_pept_group)
9461        dist_side_calf=dsqrt(dist_side_calf)
9462       do j=1,3
9463         pep_side_norm(j)=pep_side(j)/dist_pep_side
9464         side_calf_norm(j)=dist_side_calf
9465       enddo
9466 C now sscale fraction
9467        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9468 C       print *,buff_shield,"buff"
9469 C now sscale
9470         if (sh_frac_dist.le.0.0) cycle
9471 C If we reach here it means that this side chain reaches the shielding sphere
9472 C Lets add him to the list for gradient
9473         ishield_list(i)=ishield_list(i)+1
9474 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9475 C this list is essential otherwise problem would be O3
9476         shield_list(ishield_list(i),i)=k
9477 C Lets have the sscale value
9478         if (sh_frac_dist.gt.1.0) then
9479          scale_fac_dist=1.0d0
9480          do j=1,3
9481          sh_frac_dist_grad(j)=0.0d0
9482          enddo
9483         else
9484          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9485      &                   *(2.0*sh_frac_dist-3.0d0)
9486          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9487      &                  /dist_pep_side/buff_shield*0.5
9488 C remember for the final gradient multiply sh_frac_dist_grad(j)
9489 C for side_chain by factor -2 !
9490          do j=1,3
9491          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9492 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9493 C     &                    sh_frac_dist_grad(j)
9494          enddo
9495         endif
9496 C        if ((i.eq.3).and.(k.eq.2)) then
9497 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9498 C     & ,"TU"
9499 C        endif
9500
9501 C this is what is now we have the distance scaling now volume...
9502       short=short_r_sidechain(itype(k))
9503       long=long_r_sidechain(itype(k))
9504       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9505 C now costhet_grad
9506 C       costhet=0.0d0
9507        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9508 C       costhet_fac=0.0d0
9509        do j=1,3
9510          costhet_grad(j)=costhet_fac*pep_side(j)
9511        enddo
9512 C remember for the final gradient multiply costhet_grad(j)
9513 C for side_chain by factor -2 !
9514 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9515 C pep_side0pept_group is vector multiplication
9516       pep_side0pept_group=0.0
9517       do j=1,3
9518       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9519       enddo
9520       cosalfa=(pep_side0pept_group/
9521      & (dist_pep_side*dist_side_calf))
9522       fac_alfa_sin=1.0-cosalfa**2
9523       fac_alfa_sin=dsqrt(fac_alfa_sin)
9524       rkprim=fac_alfa_sin*(long-short)+short
9525 C now costhet_grad
9526        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9527        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9528
9529        do j=1,3
9530          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9531      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9532      &*(long-short)/fac_alfa_sin*cosalfa/
9533      &((dist_pep_side*dist_side_calf))*
9534      &((side_calf(j))-cosalfa*
9535      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9536
9537         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9538      &*(long-short)/fac_alfa_sin*cosalfa
9539      &/((dist_pep_side*dist_side_calf))*
9540      &(pep_side(j)-
9541      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9542        enddo
9543
9544       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9545      &                    /VSolvSphere_div
9546      &                    *wshield
9547 C now the gradient...
9548 C grad_shield is gradient of Calfa for peptide groups
9549 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9550 C     &               costhet,cosphi
9551 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9552 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9553       do j=1,3
9554       grad_shield(j,i)=grad_shield(j,i)
9555 C gradient po skalowaniu
9556      &                +(sh_frac_dist_grad(j)
9557 C  gradient po costhet
9558      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9559      &-scale_fac_dist*(cosphi_grad_long(j))
9560      &/(1.0-cosphi) )*div77_81
9561      &*VofOverlap
9562 C grad_shield_side is Cbeta sidechain gradient
9563       grad_shield_side(j,ishield_list(i),i)=
9564      &        (sh_frac_dist_grad(j)*(-2.0d0)
9565      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9566      &       +scale_fac_dist*(cosphi_grad_long(j))
9567      &        *2.0d0/(1.0-cosphi))
9568      &        *div77_81*VofOverlap
9569
9570        grad_shield_loc(j,ishield_list(i),i)=
9571      &   scale_fac_dist*cosphi_grad_loc(j)
9572      &        *2.0d0/(1.0-cosphi)
9573      &        *div77_81*VofOverlap
9574       enddo
9575       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9576       enddo
9577       fac_shield(i)=VolumeTotal*div77_81+div4_81
9578 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9579       enddo
9580       return
9581       end
9582 C--------------------------------------------------------------------------
9583 C-----------------------------------------------------------------------
9584       double precision function sscalelip(r)
9585       double precision r,gamm
9586       include "COMMON.SPLITELE"
9587 C      if(r.lt.r_cut-rlamb) then
9588 C        sscale=1.0d0
9589 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9590 C        gamm=(r-(r_cut-rlamb))/rlamb
9591         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9592 C      else
9593 C        sscale=0d0
9594 C      endif
9595       return
9596       end
9597 C-----------------------------------------------------------------------
9598       double precision function sscagradlip(r)
9599       double precision r,gamm
9600       include "COMMON.SPLITELE"
9601 C     if(r.lt.r_cut-rlamb) then
9602 C        sscagrad=0.0d0
9603 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9604 C        gamm=(r-(r_cut-rlamb))/rlamb
9605         sscagradlip=r*(6*r-6.0d0)
9606 C      else
9607 C        sscagrad=0.0d0
9608 C      endif
9609       return
9610       end
9611 c----------------------------------------------------------------------------
9612       double precision function sscale2(r,r_cut,r0,rlamb)
9613       implicit none
9614       double precision r,gamm,r_cut,r0,rlamb,rr
9615       rr = dabs(r-r0)
9616 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9617 c      write (2,*) "rr",rr
9618       if(rr.lt.r_cut-rlamb) then
9619         sscale2=1.0d0
9620       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9621         gamm=(rr-(r_cut-rlamb))/rlamb
9622         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9623       else
9624         sscale2=0d0
9625       endif
9626       return
9627       end
9628 C-----------------------------------------------------------------------
9629       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9630       implicit none
9631       double precision r,gamm,r_cut,r0,rlamb,rr
9632       rr = dabs(r-r0)
9633       if(rr.lt.r_cut-rlamb) then
9634         sscalgrad2=0.0d0
9635       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9636         gamm=(rr-(r_cut-rlamb))/rlamb
9637         if (r.ge.r0) then
9638           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9639         else
9640           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9641         endif
9642       else
9643         sscalgrad2=0.0d0
9644       endif
9645       return
9646       end
9647 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9648       subroutine Eliptransfer(eliptran)
9649       implicit real*8 (a-h,o-z)
9650       include 'DIMENSIONS'
9651       include 'COMMON.GEO'
9652       include 'COMMON.VAR'
9653       include 'COMMON.LOCAL'
9654       include 'COMMON.CHAIN'
9655       include 'COMMON.DERIV'
9656       include 'COMMON.INTERACT'
9657       include 'COMMON.IOUNITS'
9658       include 'COMMON.CALC'
9659       include 'COMMON.CONTROL'
9660       include 'COMMON.SPLITELE'
9661       include 'COMMON.SBRIDGE'
9662 C this is done by Adasko
9663 C      print *,"wchodze"
9664 C structure of box:
9665 C      water
9666 C--bordliptop-- buffore starts
9667 C--bufliptop--- here true lipid starts
9668 C      lipid
9669 C--buflipbot--- lipid ends buffore starts
9670 C--bordlipbot--buffore ends
9671       eliptran=0.0
9672       write(iout,*) "I am in?"
9673       do i=1,nres
9674 C       do i=1,1
9675         if (itype(i).eq.ntyp1) cycle
9676
9677         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9678         if (positi.le.0) positi=positi+boxzsize
9679 C        print *,i
9680 C first for peptide groups
9681 c for each residue check if it is in lipid or lipid water border area
9682        if ((positi.gt.bordlipbot)
9683      &.and.(positi.lt.bordliptop)) then
9684 C the energy transfer exist
9685         if (positi.lt.buflipbot) then
9686 C what fraction I am in
9687          fracinbuf=1.0d0-
9688      &        ((positi-bordlipbot)/lipbufthick)
9689 C lipbufthick is thickenes of lipid buffore
9690          sslip=sscalelip(fracinbuf)
9691          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9692          eliptran=eliptran+sslip*pepliptran
9693          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9694          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9695 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9696         elseif (positi.gt.bufliptop) then
9697          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9698          sslip=sscalelip(fracinbuf)
9699          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9700          eliptran=eliptran+sslip*pepliptran
9701          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9702          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9703 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9704 C          print *, "doing sscalefor top part"
9705 C         print *,i,sslip,fracinbuf,ssgradlip
9706         else
9707          eliptran=eliptran+pepliptran
9708 C         print *,"I am in true lipid"
9709         endif
9710 C       else
9711 C       eliptran=elpitran+0.0 ! I am in water
9712        endif
9713        enddo
9714 C       print *, "nic nie bylo w lipidzie?"
9715 C now multiply all by the peptide group transfer factor
9716 C       eliptran=eliptran*pepliptran
9717 C now the same for side chains
9718 CV       do i=1,1
9719        do i=1,nres
9720         if (itype(i).eq.ntyp1) cycle
9721         positi=(mod(c(3,i+nres),boxzsize))
9722         if (positi.le.0) positi=positi+boxzsize
9723 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9724 c for each residue check if it is in lipid or lipid water border area
9725 C       respos=mod(c(3,i+nres),boxzsize)
9726 C       print *,positi,bordlipbot,buflipbot
9727        if ((positi.gt.bordlipbot)
9728      & .and.(positi.lt.bordliptop)) then
9729 C the energy transfer exist
9730         if (positi.lt.buflipbot) then
9731          fracinbuf=1.0d0-
9732      &     ((positi-bordlipbot)/lipbufthick)
9733 C lipbufthick is thickenes of lipid buffore
9734          sslip=sscalelip(fracinbuf)
9735          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9736          eliptran=eliptran+sslip*liptranene(itype(i))
9737          gliptranx(3,i)=gliptranx(3,i)
9738      &+ssgradlip*liptranene(itype(i))
9739          gliptranc(3,i-1)= gliptranc(3,i-1)
9740      &+ssgradlip*liptranene(itype(i))
9741 C         print *,"doing sccale for lower part"
9742         elseif (positi.gt.bufliptop) then
9743          fracinbuf=1.0d0-
9744      &((bordliptop-positi)/lipbufthick)
9745          sslip=sscalelip(fracinbuf)
9746          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9747          eliptran=eliptran+sslip*liptranene(itype(i))
9748          gliptranx(3,i)=gliptranx(3,i)
9749      &+ssgradlip*liptranene(itype(i))
9750          gliptranc(3,i-1)= gliptranc(3,i-1)
9751      &+ssgradlip*liptranene(itype(i))
9752 C          print *, "doing sscalefor top part",sslip,fracinbuf
9753         else
9754          eliptran=eliptran+liptranene(itype(i))
9755 C         print *,"I am in true lipid"
9756         endif
9757         endif ! if in lipid or buffor
9758 C       else
9759 C       eliptran=elpitran+0.0 ! I am in water
9760        enddo
9761        return
9762        end
9763 c----------------------------------------------------------------------------
9764       subroutine e_saxs(Esaxs_constr)
9765       implicit none
9766       include 'DIMENSIONS'
9767 #ifdef MPI
9768       include "mpif.h"
9769       include "COMMON.SETUP"
9770       integer IERR
9771 #endif
9772       include 'COMMON.SBRIDGE'
9773       include 'COMMON.CHAIN'
9774       include 'COMMON.GEO'
9775       include 'COMMON.LOCAL'
9776       include 'COMMON.INTERACT'
9777       include 'COMMON.VAR'
9778       include 'COMMON.IOUNITS'
9779       include 'COMMON.DERIV'
9780       include 'COMMON.CONTROL'
9781       include 'COMMON.NAMES'
9782       include 'COMMON.FFIELD'
9783       include 'COMMON.LANGEVIN'
9784 c
9785       double precision Esaxs_constr
9786       integer i,iint,j,k,l
9787       double precision PgradC(maxSAXS,3,maxres),
9788      &  PgradX(maxSAXS,3,maxres)
9789 #ifdef MPI
9790       double precision PgradC_(maxSAXS,3,maxres),
9791      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9792 #endif
9793       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9794      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9795      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9796      & auxX,auxX1,CACAgrad,Cnorm
9797       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9798       double precision dist
9799       external dist
9800 c  SAXS restraint penalty function
9801 #ifdef DEBUG
9802       write(iout,*) "------- SAXS penalty function start -------"
9803       write (iout,*) "nsaxs",nsaxs
9804       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9805       write (iout,*) "Psaxs"
9806       do i=1,nsaxs
9807         write (iout,'(i5,e15.5)') i, Psaxs(i)
9808       enddo
9809 #endif
9810       Esaxs_constr = 0.0d0
9811       do k=1,nsaxs
9812         Pcalc(k)=0.0d0
9813         do j=1,nres
9814           do l=1,3
9815             PgradC(k,l,j)=0.0d0
9816             PgradX(k,l,j)=0.0d0
9817           enddo
9818         enddo
9819       enddo
9820       do i=iatsc_s,iatsc_e
9821        if (itype(i).eq.ntyp1) cycle
9822        do iint=1,nint_gr(i)
9823          do j=istart(i,iint),iend(i,iint)
9824            if (itype(j).eq.ntyp1) cycle
9825 #ifdef ALLSAXS
9826            dijCACA=dist(i,j)
9827            dijCASC=dist(i,j+nres)
9828            dijSCCA=dist(i+nres,j)
9829            dijSCSC=dist(i+nres,j+nres)
9830            sigma2CACA=2.0d0/(pstok**2)
9831            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9832            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9833            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9834            do k=1,nsaxs
9835              dk = distsaxs(k)
9836              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9837              if (itype(j).ne.10) then
9838              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9839              else
9840              endif
9841              expCASC = 0.0d0
9842              if (itype(i).ne.10) then
9843              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9844              else
9845              expSCCA = 0.0d0
9846              endif
9847              if (itype(i).ne.10 .and. itype(j).ne.10) then
9848              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9849              else
9850              expSCSC = 0.0d0
9851              endif
9852              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9853 #ifdef DEBUG
9854              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9855 #endif
9856              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9857              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9858              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9859              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9860              do l=1,3
9861 c CA CA
9862                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9863                PgradC(k,l,i) = PgradC(k,l,i)-aux
9864                PgradC(k,l,j) = PgradC(k,l,j)+aux
9865 c CA SC
9866                if (itype(j).ne.10) then
9867                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9868                PgradC(k,l,i) = PgradC(k,l,i)-aux
9869                PgradC(k,l,j) = PgradC(k,l,j)+aux
9870                PgradX(k,l,j) = PgradX(k,l,j)+aux
9871                endif
9872 c SC CA
9873                if (itype(i).ne.10) then
9874                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9875                PgradX(k,l,i) = PgradX(k,l,i)-aux
9876                PgradC(k,l,i) = PgradC(k,l,i)-aux
9877                PgradC(k,l,j) = PgradC(k,l,j)+aux
9878                endif
9879 c SC SC
9880                if (itype(i).ne.10 .and. itype(j).ne.10) then
9881                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9882                PgradC(k,l,i) = PgradC(k,l,i)-aux
9883                PgradC(k,l,j) = PgradC(k,l,j)+aux
9884                PgradX(k,l,i) = PgradX(k,l,i)-aux
9885                PgradX(k,l,j) = PgradX(k,l,j)+aux
9886                endif
9887              enddo ! l
9888            enddo ! k
9889 #else
9890            dijCACA=dist(i,j)
9891            sigma2CACA=scal_rad**2*0.25d0/
9892      &        (restok(itype(j))**2+restok(itype(i))**2)
9893
9894            IF (saxs_cutoff.eq.0) THEN
9895            do k=1,nsaxs
9896              dk = distsaxs(k)
9897              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9898              Pcalc(k) = Pcalc(k)+expCACA
9899              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9900              do l=1,3
9901                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9902                PgradC(k,l,i) = PgradC(k,l,i)-aux
9903                PgradC(k,l,j) = PgradC(k,l,j)+aux
9904              enddo ! l
9905            enddo ! k
9906            ELSE
9907            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9908            do k=1,nsaxs
9909              dk = distsaxs(k)
9910 c             write (2,*) "ijk",i,j,k
9911              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9912              if (sss2.eq.0.0d0) cycle
9913              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9914              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9915              Pcalc(k) = Pcalc(k)+expCACA
9916 #ifdef DEBUG
9917              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9918 #endif
9919              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9920      &             ssgrad2*expCACA/sss2
9921              do l=1,3
9922 c CA CA
9923                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9924                PgradC(k,l,i) = PgradC(k,l,i)+aux
9925                PgradC(k,l,j) = PgradC(k,l,j)-aux
9926              enddo ! l
9927            enddo ! k
9928            ENDIF
9929 #endif
9930          enddo ! j
9931        enddo ! iint
9932       enddo ! i
9933 #ifdef MPI
9934       if (nfgtasks.gt.1) then
9935         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9936      &    MPI_SUM,king,FG_COMM,IERR)
9937         if (fg_rank.eq.king) then
9938           do k=1,nsaxs
9939             Pcalc(k) = Pcalc_(k)
9940           enddo
9941         endif
9942         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9943      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9944         if (fg_rank.eq.king) then
9945           do i=1,nres
9946             do l=1,3
9947               do k=1,nsaxs
9948                 PgradC(k,l,i) = PgradC_(k,l,i)
9949               enddo
9950             enddo
9951           enddo
9952         endif
9953 #ifdef ALLSAXS
9954         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9955      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9956         if (fg_rank.eq.king) then
9957           do i=1,nres
9958             do l=1,3
9959               do k=1,nsaxs
9960                 PgradX(k,l,i) = PgradX_(k,l,i)
9961               enddo
9962             enddo
9963           enddo
9964         endif
9965 #endif
9966       endif
9967 #endif
9968 #ifdef MPI
9969       if (fg_rank.eq.king) then
9970 #endif
9971       Cnorm = 0.0d0
9972       do k=1,nsaxs
9973         Cnorm = Cnorm + Pcalc(k)
9974       enddo
9975       Esaxs_constr = dlog(Cnorm)-wsaxs0
9976       do k=1,nsaxs
9977         if (Pcalc(k).gt.0.0d0)
9978      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9979 #ifdef DEBUG
9980         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9981 #endif
9982       enddo
9983 #ifdef DEBUG
9984       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9985 #endif
9986       do i=nnt,nct
9987         do l=1,3
9988           auxC=0.0d0
9989           auxC1=0.0d0
9990           auxX=0.0d0
9991           auxX1=0.d0
9992           do k=1,nsaxs
9993             if (Pcalc(k).gt.0)
9994      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9995             auxC1 = auxC1+PgradC(k,l,i)
9996 #ifdef ALLSAXS
9997             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9998             auxX1 = auxX1+PgradX(k,l,i)
9999 #endif
10000           enddo
10001           gsaxsC(l,i) = auxC - auxC1/Cnorm
10002 #ifdef ALLSAXS
10003           gsaxsX(l,i) = auxX - auxX1/Cnorm
10004 #endif
10005 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
10006 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
10007         enddo
10008       enddo
10009 #ifdef MPI
10010       endif
10011 #endif
10012       return
10013       end
10014 c----------------------------------------------------------------------------
10015       subroutine e_saxsC(Esaxs_constr)
10016       implicit none
10017       include 'DIMENSIONS'
10018 #ifdef MPI
10019       include "mpif.h"
10020       include "COMMON.SETUP"
10021       integer IERR
10022 #endif
10023       include 'COMMON.SBRIDGE'
10024       include 'COMMON.CHAIN'
10025       include 'COMMON.INTERACT'
10026       include 'COMMON.GEO'
10027       include 'COMMON.LOCAL'
10028       include 'COMMON.VAR'
10029       include 'COMMON.IOUNITS'
10030       include 'COMMON.DERIV'
10031       include 'COMMON.CONTROL'
10032       include 'COMMON.NAMES'
10033       include 'COMMON.FFIELD'
10034       include 'COMMON.LANGEVIN'
10035 c
10036       double precision Esaxs_constr
10037       integer i,iint,j,k,l
10038       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot
10039 #ifdef MPI
10040       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
10041 #endif
10042       double precision dk,dijCASPH,dijSCSPH,
10043      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
10044      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10045      & auxX,auxX1,Cnorm
10046 c  SAXS restraint penalty function
10047 #ifdef DEBUG
10048       write(iout,*) "------- SAXS penalty function start -------"
10049       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10050      & " isaxs_end",isaxs_end
10051       write (iout,*) "nnt",nnt," ntc",nct
10052       do i=nnt,nct
10053         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10054      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10055       enddo
10056       do i=nnt,nct
10057         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10058       enddo
10059 #endif
10060       Esaxs_constr = 0.0d0
10061       logPtot=0.0d0
10062       do j=isaxs_start,isaxs_end
10063         Pcalc_=0.0d0
10064         do i=1,nres
10065           do l=1,3
10066             PgradC(l,i)=0.0d0
10067             PgradX(l,i)=0.0d0
10068           enddo
10069         enddo
10070         do i=nnt,nct
10071           dijCASPH=0.0d0
10072           dijSCSPH=0.0d0
10073           do l=1,3
10074             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10075           enddo
10076           if (itype(i).ne.10) then
10077           do l=1,3
10078             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10079           enddo
10080           endif
10081           sigma2CA=2.0d0/pstok**2
10082           sigma2SC=4.0d0/restok(itype(i))**2
10083           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10084           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10085           Pcalc_ = Pcalc_+expCASPH+expSCSPH
10086 #ifdef DEBUG
10087           write(*,*) "processor i j Pcalc_",
10088      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_
10089 #endif
10090           CASPHgrad = sigma2CA*expCASPH
10091           SCSPHgrad = sigma2SC*expSCSPH
10092           do l=1,3
10093             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10094             PgradX(l,i) = PgradX(l,i) + aux
10095             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10096           enddo ! l
10097         enddo ! i
10098         do i=nnt,nct
10099           do l=1,3
10100             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_
10101             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_
10102           enddo
10103         enddo
10104         logPtot = logPtot - dlog(Pcalc_)
10105 c        print *,"me",me,MyRank," j",j," logPcalc_",-dlog(Pcalc_),
10106 c     &    " logPtot",logPtot
10107       enddo ! j
10108 #ifdef MPI
10109       if (nfgtasks.gt.1) then
10110 c        write (iout,*) "logPtot before reduction",logPtot
10111         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10112      &    MPI_SUM,king,FG_COMM,IERR)
10113         logPtot = logPtot_
10114 c        write (iout,*) "logPtot after reduction",logPtot
10115         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10116      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10117         if (fg_rank.eq.king) then
10118           do i=1,nres
10119             do l=1,3
10120               gsaxsC(l,i) = gsaxsC_(l,i)
10121             enddo
10122           enddo
10123         endif
10124         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10125      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10126         if (fg_rank.eq.king) then
10127           do i=1,nres
10128             do l=1,3
10129               gsaxsX(l,i) = gsaxsX_(l,i)
10130             enddo
10131           enddo
10132         endif
10133       endif
10134 #endif
10135       Esaxs_constr = logPtot
10136       return
10137       end