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

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