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