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

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'sizesclu.dat'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.SHIELD'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   106 continue
  53 C      write(iout,*) "shield_mode",shield_mode,ethetacnstr
  54       if (shield_mode.eq.1) then
  55        call set_shield_fac
  56       else if  (shield_mode.eq.2) then
  57        call set_shield_fac2
  58       endif
  59       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  60 C
  61 C Calculate excluded-volume interaction energy between peptide groups
  62 C and side chains.
  63 C
  64       call escp(evdw2,evdw2_14)
  65 c
  66 c Calculate the bond-stretching energy
  67 c
  68       call ebond(estr)
  69 c      write (iout,*) "estr",estr
  70 C
  71 C Calculate the disulfide-bridge and other energy and the contributions
  72 C from other distance constraints.
  73 cd    print *,'Calling EHPB'
  74       call edis(ehpb)
  75 cd    print *,'EHPB exitted succesfully.'
  76 C
  77 C Calculate the virtual-bond-angle energy.
  78 C
  79       call ebend(ebe,ethetacnstr)
  80 cd    print *,'Bend energy finished.'
  81 C
  82 C Calculate the SC local energy.
  83 C
  84       call esc(escloc)
  85 cd    print *,'SCLOC energy finished.'
  86 C
  87 C Calculate the virtual-bond torsional energy.
  88 C
  89 cd    print *,'nterm=',nterm
  90       call etor(etors,edihcnstr,fact(1))
  91 C
  92 C 6/23/01 Calculate double-torsional energy
  93 C
  94       call etor_d(etors_d,fact(2))
  95 C
  96 C 21/5/07 Calculate local sicdechain correlation energy
  97 C
  98       call eback_sc_corr(esccor)
  99
 100       if (wliptran.gt.0) then
 101         call Eliptransfer(eliptran)
 102       endif
 103
 104 C
 105 C 12/1/95 Multi-body terms
 106 C
 107       n_corr=0
 108       n_corr1=0
 109       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 110      &    .or. wturn6.gt.0.0d0) then
 111 c         print *,"calling multibody_eello"
 112          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 113 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 114 c         print *,ecorr,ecorr5,ecorr6,eturn6
 115       else
 116          ecorr=0.0d0
 117          ecorr5=0.0d0
 118          ecorr6=0.0d0
 119          eturn6=0.0d0
 120       endif
 121       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 122          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 123       endif
 124       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 125         call e_saxs(Esaxs_constr)
 126 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 127       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 128         call e_saxsC(Esaxs_constr)
 129 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 130       else
 131         Esaxs_constr = 0.0d0
 132       endif
 133 c      write(iout,*) "TEST_ENE",constr_homology
 134       if (constr_homology.ge.1) then
 135         call e_modeller(ehomology_constr)
 136       else
 137         ehomology_constr=0.0d0
 138       endif
 139 c      write(iout,*) "TEST_ENE",ehomology_constr
 140
 141
 142 c      write (iout,*) "ft(6)",fact(6),wliptran,eliptran
 143 #ifdef SPLITELE
 144       if (shield_mode.gt.0) then
 145       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 146      & +welec*fact(1)*ees
 147      & +fact(1)*wvdwpp*evdw1
 148      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 149      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 150      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 151      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 152      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 153      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 154      & +wliptran*eliptran+wsaxs*esaxs_constr
 155       else
 156       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 157      & +wvdwpp*evdw1
 158      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 159      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 160      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 161      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 162      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 163      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 164      & +wliptran*eliptran+wsaxs*esaxs_constr
 165       endif
 166 #else
 167       if (shield_mode.gt.0) then
 168       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 169      & +welec*fact(1)*(ees+evdw1)
 170      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 171      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 172      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 173      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 174      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 175      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 176      & +wliptran*eliptran+wsaxs*esaxs_constr
 177       else
 178       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 179      & +welec*fact(1)*(ees+evdw1)
 180      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 181      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 182      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 183      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 184      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 185      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 186      & +wliptran*eliptran+wsaxs*esaxs_constr
 187       endif
 188 #endif
 189
 190       energia(0)=etot
 191       energia(1)=evdw
 192 #ifdef SCP14
 193       energia(2)=evdw2-evdw2_14
 194       energia(17)=evdw2_14
 195 #else
 196       energia(2)=evdw2
 197       energia(17)=0.0d0
 198 #endif
 199 #ifdef SPLITELE
 200       energia(3)=ees
 201       energia(16)=evdw1
 202 #else
 203       energia(3)=ees+evdw1
 204       energia(16)=0.0d0
 205 #endif
 206       energia(4)=ecorr
 207       energia(5)=ecorr5
 208       energia(6)=ecorr6
 209       energia(7)=eel_loc
 210       energia(8)=eello_turn3
 211       energia(9)=eello_turn4
 212       energia(10)=eturn6
 213       energia(11)=ebe
 214       energia(12)=escloc
 215       energia(13)=etors
 216       energia(14)=etors_d
 217       energia(15)=ehpb
 218       energia(18)=estr
 219       energia(19)=esccor
 220       energia(20)=edihcnstr
 221       energia(24)=ehomology_constr
 222       energia(21)=evdw_t
 223       energia(25)=Esaxs_constr
 224 c      energia(24)=ethetacnstr
 225       energia(22)=eliptran
 226 c detecting NaNQ
 227 #ifdef ISNAN
 228 #ifdef AIX
 229       if (isnan(etot).ne.0) energia(0)=1.0d+99
 230 #else
 231       if (isnan(etot)) energia(0)=1.0d+99
 232 #endif
 233 #else
 234       i=0
 235 #ifdef WINPGI
 236       idumm=proc_proc(etot,i)
 237 #else
 238       call proc_proc(etot,i)
 239 #endif
 240       if(i.eq.1)energia(0)=1.0d+99
 241 #endif
 242 #ifdef MPL
 243 c     endif
 244 #endif
 245       if (calc_grad) then
 246 C
 247 C Sum up the components of the Cartesian gradient.
 248 C
 249 #ifdef SPLITELE
 250       do i=1,nct
 251         do j=1,3
 252       if (shield_mode.eq.0) then
 253           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 254      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 255      &                wbond*gradb(j,i)+
 256      &                wstrain*ghpbc(j,i)+
 257      &                wcorr*fact(3)*gradcorr(j,i)+
 258      &                wel_loc*fact(2)*gel_loc(j,i)+
 259      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 260      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 261      &                wcorr5*fact(4)*gradcorr5(j,i)+
 262      &                wcorr6*fact(5)*gradcorr6(j,i)+
 263      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 264      &                wsccor*fact(2)*gsccorc(j,i)
 265      &               +wliptran*gliptranc(j,i)
 266           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 267      &                  wbond*gradbx(j,i)+
 268      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 269      &                  wsccor*fact(2)*gsccorx(j,i)
 270      &                 +wliptran*gliptranx(j,i)
 271         else
 272           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 273      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 274      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 275      &                wbond*gradb(j,i)+
 276      &                wstrain*ghpbc(j,i)+
 277      &                wcorr*fact(3)*gradcorr(j,i)+
 278      &                wel_loc*fact(2)*gel_loc(j,i)+
 279      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 280      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 281      &                wcorr5*fact(4)*gradcorr5(j,i)+
 282      &                wcorr6*fact(5)*gradcorr6(j,i)+
 283      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 284      &                wsccor*fact(2)*gsccorc(j,i)
 285      &               +wliptran*gliptranc(j,i)
 286      &                 +welec*gshieldc(j,i)
 287      &                 +welec*gshieldc_loc(j,i)
 288      &                 +wcorr*gshieldc_ec(j,i)
 289      &                 +wcorr*gshieldc_loc_ec(j,i)
 290      &                 +wturn3*gshieldc_t3(j,i)
 291      &                 +wturn3*gshieldc_loc_t3(j,i)
 292      &                 +wturn4*gshieldc_t4(j,i)
 293      &                 +wturn4*gshieldc_loc_t4(j,i)
 294      &                 +wel_loc*gshieldc_ll(j,i)
 295      &                 +wel_loc*gshieldc_loc_ll(j,i)
 296
 297           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 298      &                 +fact(1)*wscp*gradx_scp(j,i)+
 299      &                  wbond*gradbx(j,i)+
 300      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 301      &                  wsccor*fact(2)*gsccorx(j,i)
 302      &                 +wliptran*gliptranx(j,i)
 303      &                 +welec*gshieldx(j,i)
 304      &                 +wcorr*gshieldx_ec(j,i)
 305      &                 +wturn3*gshieldx_t3(j,i)
 306      &                 +wturn4*gshieldx_t4(j,i)
 307      &                 +wel_loc*gshieldx_ll(j,i)
 308
 309
 310         endif
 311         enddo
 312 #else
 313        do i=1,nct
 314         do j=1,3
 315                 if (shield_mode.eq.0) then
 316           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 317      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 318      &                wbond*gradb(j,i)+
 319      &                wcorr*fact(3)*gradcorr(j,i)+
 320      &                wel_loc*fact(2)*gel_loc(j,i)+
 321      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 322      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 323      &                wcorr5*fact(4)*gradcorr5(j,i)+
 324      &                wcorr6*fact(5)*gradcorr6(j,i)+
 325      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 326      &                wsccor*fact(2)*gsccorc(j,i)
 327      &               +wliptran*gliptranc(j,i)
 328           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 329      &                  wbond*gradbx(j,i)+
 330      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 331      &                  wsccor*fact(1)*gsccorx(j,i)
 332      &                 +wliptran*gliptranx(j,i)
 333               else
 334           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 335      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 336      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 337      &                wbond*gradb(j,i)+
 338      &                wcorr*fact(3)*gradcorr(j,i)+
 339      &                wel_loc*fact(2)*gel_loc(j,i)+
 340      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 341      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 342      &                wcorr5*fact(4)*gradcorr5(j,i)+
 343      &                wcorr6*fact(5)*gradcorr6(j,i)+
 344      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 345      &                wsccor*fact(2)*gsccorc(j,i)
 346      &               +wliptran*gliptranc(j,i)
 347           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 348      &                  fact(1)*wscp*gradx_scp(j,i)+
 349      &                  wbond*gradbx(j,i)+
 350      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 351      &                  wsccor*fact(1)*gsccorx(j,i)
 352      &                 +wliptran*gliptranx(j,i)
 353          endif
 354         enddo
 355 #endif
 356       enddo
 357
 358
 359       do i=1,nres-3
 360         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 361      &   +wcorr5*fact(4)*g_corr5_loc(i)
 362      &   +wcorr6*fact(5)*g_corr6_loc(i)
 363      &   +wturn4*fact(3)*gel_loc_turn4(i)
 364      &   +wturn3*fact(2)*gel_loc_turn3(i)
 365      &   +wturn6*fact(5)*gel_loc_turn6(i)
 366      &   +wel_loc*fact(2)*gel_loc_loc(i)
 367 c     &   +wsccor*fact(1)*gsccor_loc(i)
 368 c ROZNICA Z WHAMem
 369       enddo
 370       endif
 371       if (dyn_ss) call dyn_set_nss
 372       return
 373       end
 374 C------------------------------------------------------------------------
 375       subroutine enerprint(energia,fact)
 376       implicit real*8 (a-h,o-z)
 377       include 'DIMENSIONS'
 378       include 'sizesclu.dat'
 379       include 'COMMON.IOUNITS'
 380       include 'COMMON.FFIELD'
 381       include 'COMMON.SBRIDGE'
 382       double precision energia(0:max_ene),fact(6)
 383       etot=energia(0)
 384       evdw=energia(1)+fact(6)*energia(21)
 385 #ifdef SCP14
 386       evdw2=energia(2)+energia(17)
 387 #else
 388       evdw2=energia(2)
 389 #endif
 390       ees=energia(3)
 391 #ifdef SPLITELE
 392       evdw1=energia(16)
 393 #endif
 394       ecorr=energia(4)
 395       ecorr5=energia(5)
 396       ecorr6=energia(6)
 397       eel_loc=energia(7)
 398       eello_turn3=energia(8)
 399       eello_turn4=energia(9)
 400       eello_turn6=energia(10)
 401       ebe=energia(11)
 402       escloc=energia(12)
 403       etors=energia(13)
 404       etors_d=energia(14)
 405       ehpb=energia(15)
 406       esccor=energia(19)
 407       edihcnstr=energia(20)
 408       estr=energia(18)
 409       ehomology_constr=energia(24)
 410       esaxs_constr=energia(25)
 411 c      ethetacnstr=energia(24)
 412 #ifdef SPLITELE
 413       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 414      &  wvdwpp,
 415      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 416      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 417      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 418      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 419      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 420      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,
 421      &  wsaxs*esaxs_constr,ebr*nss,etot
 422    10 format (/'Virtual-chain energies:'//
 423      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 424      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 425      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 426      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 427      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 428      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 429      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 430      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 431      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 432      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 433      & ' (SS bridges & dist. cnstr.)'/
 434      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 435      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 436      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 437      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 438      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 439      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 440      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 441      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 442      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 443      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 444      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
 445      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 446      & 'ETOT=  ',1pE16.6,' (total)')
 447 #else
 448       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 449      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 450      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 451      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 452      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 453      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 454      &  edihcnstr,ehomology_constr,esaxs_constr*wsaxs,ebr*nss,
 455      &  etot
 456    10 format (/'Virtual-chain energies:'//
 457      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 458      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 459      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 460      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 461      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 462      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 463      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 464      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 465      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 466      & ' (SS bridges & dist. cnstr.)'/
 467      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 468      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 469      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 470      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 471      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 472      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 473      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 474      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 475      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 476      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 477      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
 478      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 479      & 'ETOT=  ',1pE16.6,' (total)')
 480 #endif
 481       return
 482       end
 483 C-----------------------------------------------------------------------
 484       subroutine elj(evdw,evdw_t)
 485 C
 486 C This subroutine calculates the interaction energy of nonbonded side chains
 487 C assuming the LJ potential of interaction.
 488 C
 489       implicit real*8 (a-h,o-z)
 490       include 'DIMENSIONS'
 491       include 'sizesclu.dat'
 492       include "DIMENSIONS.COMPAR"
 493       parameter (accur=1.0d-10)
 494       include 'COMMON.GEO'
 495       include 'COMMON.VAR'
 496       include 'COMMON.LOCAL'
 497       include 'COMMON.CHAIN'
 498       include 'COMMON.DERIV'
 499       include 'COMMON.INTERACT'
 500       include 'COMMON.TORSION'
 501       include 'COMMON.SBRIDGE'
 502       include 'COMMON.NAMES'
 503       include 'COMMON.IOUNITS'
 504       include 'COMMON.CONTACTS'
 505       dimension gg(3)
 506       integer icant
 507       external icant
 508 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 509 c ROZNICA DODANE Z WHAM
 510 c      do i=1,210
 511 c        do j=1,2
 512 c          eneps_temp(j,i)=0.0d0
 513 c        enddo
 514 c      enddo
 515 cROZNICA
 516
 517       evdw=0.0D0
 518       evdw_t=0.0d0
 519       do i=iatsc_s,iatsc_e
 520         itypi=iabs(itype(i))
 521         if (itypi.eq.ntyp1) cycle
 522         itypi1=iabs(itype(i+1))
 523         xi=c(1,nres+i)
 524         yi=c(2,nres+i)
 525         zi=c(3,nres+i)
 526 C Change 12/1/95
 527         num_conti=0
 528 C
 529 C Calculate SC interaction energy.
 530 C
 531         do iint=1,nint_gr(i)
 532 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 533 cd   &                  'iend=',iend(i,iint)
 534           do j=istart(i,iint),iend(i,iint)
 535             itypj=iabs(itype(j))
 536             if (itypj.eq.ntyp1) cycle
 537             xj=c(1,nres+j)-xi
 538             yj=c(2,nres+j)-yi
 539             zj=c(3,nres+j)-zi
 540 C Change 12/1/95 to calculate four-body interactions
 541             rij=xj*xj+yj*yj+zj*zj
 542             rrij=1.0D0/rij
 543 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 544             eps0ij=eps(itypi,itypj)
 545             fac=rrij**expon2
 546             e1=fac*fac*aa
 547             e2=fac*bb
 548             evdwij=e1+e2
 549             ij=icant(itypi,itypj)
 550 c ROZNICA z WHAM
 551 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 552 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 553 c
 554
 555 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 556 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 557 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 558 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 559 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 560 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 561             if (bb.gt.0.0d0) then
 562               evdw=evdw+evdwij
 563             else
 564               evdw_t=evdw_t+evdwij
 565             endif
 566             if (calc_grad) then
 567 C
 568 C Calculate the components of the gradient in DC and X
 569 C
 570             fac=-rrij*(e1+evdwij)
 571             gg(1)=xj*fac
 572             gg(2)=yj*fac
 573             gg(3)=zj*fac
 574             do k=1,3
 575               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 576               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 577             enddo
 578             do k=i,j-1
 579               do l=1,3
 580                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 581               enddo
 582             enddo
 583             endif
 584 C
 585 C 12/1/95, revised on 5/20/97
 586 C
 587 C Calculate the contact function. The ith column of the array JCONT will
 588 C contain the numbers of atoms that make contacts with the atom I (of numbers
 589 C greater than I). The arrays FACONT and GACONT will contain the values of
 590 C the contact function and its derivative.
 591 C
 592 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 593 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 594 C Uncomment next line, if the correlation interactions are contact function only
 595             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 596               rij=dsqrt(rij)
 597               sigij=sigma(itypi,itypj)
 598               r0ij=rs0(itypi,itypj)
 599 C
 600 C Check whether the SC's are not too far to make a contact.
 601 C
 602               rcut=1.5d0*r0ij
 603               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 604 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 605 C
 606               if (fcont.gt.0.0D0) then
 607 C If the SC-SC distance if close to sigma, apply spline.
 608 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 609 cAdam &             fcont1,fprimcont1)
 610 cAdam           fcont1=1.0d0-fcont1
 611 cAdam           if (fcont1.gt.0.0d0) then
 612 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 613 cAdam             fcont=fcont*fcont1
 614 cAdam           endif
 615 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 616 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 617 cga             do k=1,3
 618 cga               gg(k)=gg(k)*eps0ij
 619 cga             enddo
 620 cga             eps0ij=-evdwij*eps0ij
 621 C Uncomment for AL's type of SC correlation interactions.
 622 cadam           eps0ij=-evdwij
 623                 num_conti=num_conti+1
 624                 jcont(num_conti,i)=j
 625                 facont(num_conti,i)=fcont*eps0ij
 626                 fprimcont=eps0ij*fprimcont/rij
 627                 fcont=expon*fcont
 628 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 629 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 630 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 631 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 632                 gacont(1,num_conti,i)=-fprimcont*xj
 633                 gacont(2,num_conti,i)=-fprimcont*yj
 634                 gacont(3,num_conti,i)=-fprimcont*zj
 635 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 636 cd              write (iout,'(2i3,3f10.5)')
 637 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 638               endif
 639             endif
 640           enddo      ! j
 641         enddo        ! iint
 642 C Change 12/1/95
 643         num_cont(i)=num_conti
 644       enddo          ! i
 645       if (calc_grad) then
 646       do i=1,nct
 647         do j=1,3
 648           gvdwc(j,i)=expon*gvdwc(j,i)
 649           gvdwx(j,i)=expon*gvdwx(j,i)
 650         enddo
 651       enddo
 652       endif
 653 C******************************************************************************
 654 C
 655 C                              N O T E !!!
 656 C
 657 C To save time, the factor of EXPON has been extracted from ALL components
 658 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 659 C use!
 660 C
 661 C******************************************************************************
 662       return
 663       end
 664 C-----------------------------------------------------------------------------
 665       subroutine eljk(evdw,evdw_t)
 666 C
 667 C This subroutine calculates the interaction energy of nonbonded side chains
 668 C assuming the LJK potential of interaction.
 669 C
 670       implicit real*8 (a-h,o-z)
 671       include 'DIMENSIONS'
 672       include 'sizesclu.dat'
 673       include "DIMENSIONS.COMPAR"
 674       include 'COMMON.GEO'
 675       include 'COMMON.VAR'
 676       include 'COMMON.LOCAL'
 677       include 'COMMON.CHAIN'
 678       include 'COMMON.DERIV'
 679       include 'COMMON.INTERACT'
 680       include 'COMMON.IOUNITS'
 681       include 'COMMON.NAMES'
 682       dimension gg(3)
 683       logical scheck
 684       integer icant
 685       external icant
 686 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 687       evdw=0.0D0
 688       evdw_t=0.0d0
 689       do i=iatsc_s,iatsc_e
 690         itypi=iabs(itype(i))
 691         if (itypi.eq.ntyp1) cycle
 692         itypi1=iabs(itype(i+1))
 693         xi=c(1,nres+i)
 694         yi=c(2,nres+i)
 695         zi=c(3,nres+i)
 696 C
 697 C Calculate SC interaction energy.
 698 C
 699         do iint=1,nint_gr(i)
 700           do j=istart(i,iint),iend(i,iint)
 701             itypj=iabs(itype(j))
 702             if (itypj.eq.ntyp1) cycle
 703             xj=c(1,nres+j)-xi
 704             yj=c(2,nres+j)-yi
 705             zj=c(3,nres+j)-zi
 706             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 707             fac_augm=rrij**expon
 708             e_augm=augm(itypi,itypj)*fac_augm
 709             r_inv_ij=dsqrt(rrij)
 710             rij=1.0D0/r_inv_ij
 711             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 712             fac=r_shift_inv**expon
 713             e1=fac*fac*aa
 714             e2=fac*bb
 715             evdwij=e_augm+e1+e2
 716             ij=icant(itypi,itypj)
 717 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 718 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 719 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 720 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 721 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 722 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 723 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 724             if (bb.gt.0.0d0) then
 725               evdw=evdw+evdwij
 726             else
 727               evdw_t=evdw_t+evdwij
 728             endif
 729             if (calc_grad) then
 730 C
 731 C Calculate the components of the gradient in DC and X
 732 C
 733             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 734             gg(1)=xj*fac
 735             gg(2)=yj*fac
 736             gg(3)=zj*fac
 737             do k=1,3
 738               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 739               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 740             enddo
 741             do k=i,j-1
 742               do l=1,3
 743                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 744               enddo
 745             enddo
 746             endif
 747           enddo      ! j
 748         enddo        ! iint
 749       enddo          ! i
 750       if (calc_grad) then
 751       do i=1,nct
 752         do j=1,3
 753           gvdwc(j,i)=expon*gvdwc(j,i)
 754           gvdwx(j,i)=expon*gvdwx(j,i)
 755         enddo
 756       enddo
 757       endif
 758       return
 759       end
 760 C-----------------------------------------------------------------------------
 761       subroutine ebp(evdw,evdw_t)
 762 C
 763 C This subroutine calculates the interaction energy of nonbonded side chains
 764 C assuming the Berne-Pechukas potential of interaction.
 765 C
 766       implicit real*8 (a-h,o-z)
 767       include 'DIMENSIONS'
 768       include 'sizesclu.dat'
 769       include "DIMENSIONS.COMPAR"
 770       include 'COMMON.GEO'
 771       include 'COMMON.VAR'
 772       include 'COMMON.LOCAL'
 773       include 'COMMON.CHAIN'
 774       include 'COMMON.DERIV'
 775       include 'COMMON.NAMES'
 776       include 'COMMON.INTERACT'
 777       include 'COMMON.IOUNITS'
 778       include 'COMMON.CALC'
 779       common /srutu/ icall
 780 c     double precision rrsave(maxdim)
 781       logical lprn
 782       integer icant
 783       external icant
 784       evdw=0.0D0
 785       evdw_t=0.0d0
 786 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 787 c     if (icall.eq.0) then
 788 c       lprn=.true.
 789 c     else
 790         lprn=.false.
 791 c     endif
 792       ind=0
 793       do i=iatsc_s,iatsc_e
 794         itypi=iabs(itype(i))
 795         if (itypi.eq.ntyp1) cycle
 796         itypi1=iabs(itype(i+1))
 797         xi=c(1,nres+i)
 798         yi=c(2,nres+i)
 799         zi=c(3,nres+i)
 800         dxi=dc_norm(1,nres+i)
 801         dyi=dc_norm(2,nres+i)
 802         dzi=dc_norm(3,nres+i)
 803         dsci_inv=vbld_inv(i+nres)
 804 C
 805 C Calculate SC interaction energy.
 806 C
 807         do iint=1,nint_gr(i)
 808           do j=istart(i,iint),iend(i,iint)
 809             ind=ind+1
 810             itypj=iabs(itype(j))
 811             if (itypj.eq.ntyp1) cycle
 812             dscj_inv=vbld_inv(j+nres)
 813             chi1=chi(itypi,itypj)
 814             chi2=chi(itypj,itypi)
 815             chi12=chi1*chi2
 816             chip1=chip(itypi)
 817             chip2=chip(itypj)
 818             chip12=chip1*chip2
 819             alf1=alp(itypi)
 820             alf2=alp(itypj)
 821             alf12=0.5D0*(alf1+alf2)
 822 C For diagnostics only!!!
 823 c           chi1=0.0D0
 824 c           chi2=0.0D0
 825 c           chi12=0.0D0
 826 c           chip1=0.0D0
 827 c           chip2=0.0D0
 828 c           chip12=0.0D0
 829 c           alf1=0.0D0
 830 c           alf2=0.0D0
 831 c           alf12=0.0D0
 832             xj=c(1,nres+j)-xi
 833             yj=c(2,nres+j)-yi
 834             zj=c(3,nres+j)-zi
 835             dxj=dc_norm(1,nres+j)
 836             dyj=dc_norm(2,nres+j)
 837             dzj=dc_norm(3,nres+j)
 838             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 839 cd          if (icall.eq.0) then
 840 cd            rrsave(ind)=rrij
 841 cd          else
 842 cd            rrij=rrsave(ind)
 843 cd          endif
 844             rij=dsqrt(rrij)
 845 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 846             call sc_angular
 847 C Calculate whole angle-dependent part of epsilon and contributions
 848 C to its derivatives
 849             fac=(rrij*sigsq)**expon2
 850             e1=fac*fac*aa
 851             e2=fac*bb
 852             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 853             eps2der=evdwij*eps3rt
 854             eps3der=evdwij*eps2rt
 855             evdwij=evdwij*eps2rt*eps3rt
 856             ij=icant(itypi,itypj)
 857             aux=eps1*eps2rt**2*eps3rt**2
 858             if (bb.gt.0.0d0) then
 859               evdw=evdw+evdwij
 860             else
 861               evdw_t=evdw_t+evdwij
 862             endif
 863             if (calc_grad) then
 864             if (lprn) then
 865             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 866             epsi=bb**2/aa
 867 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 868 cd     &        restyp(itypi),i,restyp(itypj),j,
 869 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 870 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 871 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 872 cd     &        evdwij
 873             endif
 874 C Calculate gradient components.
 875             e1=e1*eps1*eps2rt**2*eps3rt**2
 876             fac=-expon*(e1+evdwij)
 877             sigder=fac/sigsq
 878             fac=rrij*fac
 879 C Calculate radial part of the gradient
 880             gg(1)=xj*fac
 881             gg(2)=yj*fac
 882             gg(3)=zj*fac
 883 C Calculate the angular part of the gradient and sum add the contributions
 884 C to the appropriate components of the Cartesian gradient.
 885             call sc_grad
 886             endif
 887           enddo      ! j
 888         enddo        ! iint
 889       enddo          ! i
 890 c     stop
 891       return
 892       end
 893 C-----------------------------------------------------------------------------
 894       subroutine egb(evdw,evdw_t)
 895 C
 896 C This subroutine calculates the interaction energy of nonbonded side chains
 897 C assuming the Gay-Berne potential of interaction.
 898 C
 899       implicit real*8 (a-h,o-z)
 900       include 'DIMENSIONS'
 901       include 'sizesclu.dat'
 902       include "DIMENSIONS.COMPAR"
 903       include 'COMMON.GEO'
 904       include 'COMMON.VAR'
 905       include 'COMMON.LOCAL'
 906       include 'COMMON.CHAIN'
 907       include 'COMMON.DERIV'
 908       include 'COMMON.NAMES'
 909       include 'COMMON.INTERACT'
 910       include 'COMMON.IOUNITS'
 911       include 'COMMON.CALC'
 912       include 'COMMON.SBRIDGE'
 913       logical lprn
 914       common /srutu/icall
 915       integer icant
 916       external icant
 917       integer xshift,yshift,zshift
 918       logical energy_dec /.false./
 919 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 920       evdw=0.0D0
 921       evdw_t=0.0d0
 922       lprn=.false.
 923 c      if (icall.gt.0) lprn=.true.
 924       ind=0
 925       do i=iatsc_s,iatsc_e
 926         itypi=iabs(itype(i))
 927         if (itypi.eq.ntyp1) cycle
 928         itypi1=iabs(itype(i+1))
 929         xi=c(1,nres+i)
 930         yi=c(2,nres+i)
 931         zi=c(3,nres+i)
 932           xi=mod(xi,boxxsize)
 933           if (xi.lt.0) xi=xi+boxxsize
 934           yi=mod(yi,boxysize)
 935           if (yi.lt.0) yi=yi+boxysize
 936           zi=mod(zi,boxzsize)
 937           if (zi.lt.0) zi=zi+boxzsize
 938        if ((zi.gt.bordlipbot)
 939      &.and.(zi.lt.bordliptop)) then
 940 C the energy transfer exist
 941         if (zi.lt.buflipbot) then
 942 C what fraction I am in
 943          fracinbuf=1.0d0-
 944      &        ((zi-bordlipbot)/lipbufthick)
 945 C lipbufthick is thickenes of lipid buffore
 946          sslipi=sscalelip(fracinbuf)
 947          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 948         elseif (zi.gt.bufliptop) then
 949          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 950          sslipi=sscalelip(fracinbuf)
 951          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 952         else
 953          sslipi=1.0d0
 954          ssgradlipi=0.0
 955         endif
 956        else
 957          sslipi=0.0d0
 958          ssgradlipi=0.0
 959        endif
 960         dxi=dc_norm(1,nres+i)
 961         dyi=dc_norm(2,nres+i)
 962         dzi=dc_norm(3,nres+i)
 963         dsci_inv=vbld_inv(i+nres)
 964 C
 965 C Calculate SC interaction energy.
 966 C
 967         do iint=1,nint_gr(i)
 968           do j=istart(i,iint),iend(i,iint)
 969             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 970
 971 c              write(iout,*) "PRZED ZWYKLE", evdwij
 972               call dyn_ssbond_ene(i,j,evdwij)
 973 c              write(iout,*) "PO ZWYKLE", evdwij
 974
 975               evdw=evdw+evdwij
 976               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 977      &                        'evdw',i,j,evdwij,' ss'
 978 C triple bond artifac removal
 979              do k=j+1,iend(i,iint)
 980 C search over all next residues
 981               if (dyn_ss_mask(k)) then
 982 C check if they are cysteins
 983 C              write(iout,*) 'k=',k
 984
 985 c              write(iout,*) "PRZED TRI", evdwij
 986                evdwij_przed_tri=evdwij
 987               call triple_ssbond_ene(i,j,k,evdwij)
 988 c               if(evdwij_przed_tri.ne.evdwij) then
 989 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
 990 c               endif
 991
 992 c              write(iout,*) "PO TRI", evdwij
 993 C call the energy function that removes the artifical triple disulfide
 994 C bond the soubroutine is located in ssMD.F
 995               evdw=evdw+evdwij
 996               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 997      &                        'evdw',i,j,evdwij,'tss'
 998               endif!dyn_ss_mask(k)
 999              enddo! k
1000             ELSE
1001             ind=ind+1
1002             itypj=iabs(itype(j))
1003             if (itypj.eq.ntyp1) cycle
1004             dscj_inv=vbld_inv(j+nres)
1005             sig0ij=sigma(itypi,itypj)
1006             chi1=chi(itypi,itypj)
1007             chi2=chi(itypj,itypi)
1008             chi12=chi1*chi2
1009             chip1=chip(itypi)
1010             chip2=chip(itypj)
1011             chip12=chip1*chip2
1012             alf1=alp(itypi)
1013             alf2=alp(itypj)
1014             alf12=0.5D0*(alf1+alf2)
1015 C For diagnostics only!!!
1016 c           chi1=0.0D0
1017 c           chi2=0.0D0
1018 c           chi12=0.0D0
1019 c           chip1=0.0D0
1020 c           chip2=0.0D0
1021 c           chip12=0.0D0
1022 c           alf1=0.0D0
1023 c           alf2=0.0D0
1024 c           alf12=0.0D0
1025             xj=c(1,nres+j)
1026             yj=c(2,nres+j)
1027             zj=c(3,nres+j)
1028           xj=mod(xj,boxxsize)
1029           if (xj.lt.0) xj=xj+boxxsize
1030           yj=mod(yj,boxysize)
1031           if (yj.lt.0) yj=yj+boxysize
1032           zj=mod(zj,boxzsize)
1033           if (zj.lt.0) zj=zj+boxzsize
1034        if ((zj.gt.bordlipbot)
1035      &.and.(zj.lt.bordliptop)) then
1036 C the energy transfer exist
1037         if (zj.lt.buflipbot) then
1038 C what fraction I am in
1039          fracinbuf=1.0d0-
1040      &        ((zj-bordlipbot)/lipbufthick)
1041 C lipbufthick is thickenes of lipid buffore
1042          sslipj=sscalelip(fracinbuf)
1043          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1044         elseif (zj.gt.bufliptop) then
1045          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1046          sslipj=sscalelip(fracinbuf)
1047          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1048         else
1049          sslipj=1.0d0
1050          ssgradlipj=0.0
1051         endif
1052        else
1053          sslipj=0.0d0
1054          ssgradlipj=0.0
1055        endif
1056       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1057      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1058       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1059      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1060 C      write(iout,*) "czy jest 0", bb-bb_lip(itypi,itypj),
1061 C     & bb-bb_aq(itypi,itypj)
1062       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1063       xj_safe=xj
1064       yj_safe=yj
1065       zj_safe=zj
1066       subchap=0
1067       do xshift=-1,1
1068       do yshift=-1,1
1069       do zshift=-1,1
1070           xj=xj_safe+xshift*boxxsize
1071           yj=yj_safe+yshift*boxysize
1072           zj=zj_safe+zshift*boxzsize
1073           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1074           if(dist_temp.lt.dist_init) then
1075             dist_init=dist_temp
1076             xj_temp=xj
1077             yj_temp=yj
1078             zj_temp=zj
1079             subchap=1
1080           endif
1081        enddo
1082        enddo
1083        enddo
1084        if (subchap.eq.1) then
1085           xj=xj_temp-xi
1086           yj=yj_temp-yi
1087           zj=zj_temp-zi
1088        else
1089           xj=xj_safe-xi
1090           yj=yj_safe-yi
1091           zj=zj_safe-zi
1092        endif
1093             dxj=dc_norm(1,nres+j)
1094             dyj=dc_norm(2,nres+j)
1095             dzj=dc_norm(3,nres+j)
1096 c            write (iout,*) i,j,xj,yj,zj
1097             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1098             rij=dsqrt(rrij)
1099             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1100             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1101             if (sss.le.0.0d0) cycle
1102 C Calculate angle-dependent terms of energy and contributions to their
1103 C derivatives.
1104             call sc_angular
1105             sigsq=1.0D0/sigsq
1106             sig=sig0ij*dsqrt(sigsq)
1107             rij_shift=1.0D0/rij-sig+sig0ij
1108 C I hate to put IF's in the loops, but here don't have another choice!!!!
1109             if (rij_shift.le.0.0D0) then
1110               evdw=1.0D20
1111               return
1112             endif
1113             sigder=-sig*sigsq
1114 c---------------------------------------------------------------
1115             rij_shift=1.0D0/rij_shift
1116             fac=rij_shift**expon
1117             e1=fac*fac*aa
1118             e2=fac*bb
1119             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1120             eps2der=evdwij*eps3rt
1121             eps3der=evdwij*eps2rt
1122             evdwij=evdwij*eps2rt*eps3rt
1123             if (bb.gt.0) then
1124               evdw=evdw+evdwij*sss
1125             else
1126               evdw_t=evdw_t+evdwij*sss
1127             endif
1128             ij=icant(itypi,itypj)
1129             aux=eps1*eps2rt**2*eps3rt**2
1130 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1131 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1132 c     &         aux*e2/eps(itypi,itypj)
1133 c            if (lprn) then
1134             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1135             epsi=bb**2/aa
1136 C#define DEBUG
1137 #ifdef DEBUG
1138 C            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1139 C     &        restyp(itypi),i,restyp(itypj),j,
1140 C     &        epsi,sigm,chi1,chi2,chip1,chip2,
1141 C     &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1142 C     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1143 C     &        evdwij
1144              write (iout,*) "pratial sum", evdw,evdw_t,e1,e2,fac,aa
1145 #endif
1146 C#undef DEBUG
1147 c            endif
1148             if (calc_grad) then
1149 C Calculate gradient components.
1150             e1=e1*eps1*eps2rt**2*eps3rt**2
1151             fac=-expon*(e1+evdwij)*rij_shift
1152             sigder=fac*sigder
1153             fac=rij*fac
1154             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1155             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1156      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1157      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1158      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1159             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1160             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1161 C Calculate the radial part of the gradient
1162             gg(1)=xj*fac
1163             gg(2)=yj*fac
1164             gg(3)=zj*fac
1165 C Calculate angular part of the gradient.
1166             call sc_grad
1167             endif
1168             ENDIF    ! dyn_ss
1169           enddo      ! j
1170         enddo        ! iint
1171       enddo          ! i
1172       return
1173       end
1174 C-----------------------------------------------------------------------------
1175       subroutine egbv(evdw,evdw_t)
1176 C
1177 C This subroutine calculates the interaction energy of nonbonded side chains
1178 C assuming the Gay-Berne-Vorobjev potential of interaction.
1179 C
1180       implicit real*8 (a-h,o-z)
1181       include 'DIMENSIONS'
1182       include 'sizesclu.dat'
1183       include "DIMENSIONS.COMPAR"
1184       include 'COMMON.GEO'
1185       include 'COMMON.VAR'
1186       include 'COMMON.LOCAL'
1187       include 'COMMON.CHAIN'
1188       include 'COMMON.DERIV'
1189       include 'COMMON.NAMES'
1190       include 'COMMON.INTERACT'
1191       include 'COMMON.IOUNITS'
1192       include 'COMMON.CALC'
1193       common /srutu/ icall
1194       logical lprn
1195       integer icant
1196       external icant
1197       integer xshift,yshift,zshift
1198       evdw=0.0D0
1199       evdw_t=0.0d0
1200 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1201       evdw=0.0D0
1202       lprn=.false.
1203 c      if (icall.gt.0) lprn=.true.
1204       ind=0
1205       do i=iatsc_s,iatsc_e
1206         itypi=iabs(itype(i))
1207         if (itypi.eq.ntyp1) cycle
1208         itypi1=iabs(itype(i+1))
1209         xi=c(1,nres+i)
1210         yi=c(2,nres+i)
1211         zi=c(3,nres+i)
1212         dxi=dc_norm(1,nres+i)
1213         dyi=dc_norm(2,nres+i)
1214         dzi=dc_norm(3,nres+i)
1215         dsci_inv=vbld_inv(i+nres)
1216 C returning the ith atom to box
1217           xi=mod(xi,boxxsize)
1218           if (xi.lt.0) xi=xi+boxxsize
1219           yi=mod(yi,boxysize)
1220           if (yi.lt.0) yi=yi+boxysize
1221           zi=mod(zi,boxzsize)
1222           if (zi.lt.0) zi=zi+boxzsize
1223        if ((zi.gt.bordlipbot)
1224      &.and.(zi.lt.bordliptop)) then
1225 C the energy transfer exist
1226         if (zi.lt.buflipbot) then
1227 C what fraction I am in
1228          fracinbuf=1.0d0-
1229      &        ((zi-bordlipbot)/lipbufthick)
1230 C lipbufthick is thickenes of lipid buffore
1231          sslipi=sscalelip(fracinbuf)
1232          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1233         elseif (zi.gt.bufliptop) then
1234          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1235          sslipi=sscalelip(fracinbuf)
1236          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1237         else
1238          sslipi=1.0d0
1239          ssgradlipi=0.0
1240         endif
1241        else
1242          sslipi=0.0d0
1243          ssgradlipi=0.0
1244        endif
1245 C
1246 C Calculate SC interaction energy.
1247 C
1248         do iint=1,nint_gr(i)
1249           do j=istart(i,iint),iend(i,iint)
1250             ind=ind+1
1251             itypj=iabs(itype(j))
1252             if (itypj.eq.ntyp1) cycle
1253             dscj_inv=vbld_inv(j+nres)
1254             sig0ij=sigma(itypi,itypj)
1255             r0ij=r0(itypi,itypj)
1256             chi1=chi(itypi,itypj)
1257             chi2=chi(itypj,itypi)
1258             chi12=chi1*chi2
1259             chip1=chip(itypi)
1260             chip2=chip(itypj)
1261             chip12=chip1*chip2
1262             alf1=alp(itypi)
1263             alf2=alp(itypj)
1264             alf12=0.5D0*(alf1+alf2)
1265 C For diagnostics only!!!
1266 c           chi1=0.0D0
1267 c           chi2=0.0D0
1268 c           chi12=0.0D0
1269 c           chip1=0.0D0
1270 c           chip2=0.0D0
1271 c           chip12=0.0D0
1272 c           alf1=0.0D0
1273 c           alf2=0.0D0
1274 c           alf12=0.0D0
1275             xj=c(1,nres+j)
1276             yj=c(2,nres+j)
1277             zj=c(3,nres+j)
1278 C returning jth atom to box
1279           xj=mod(xj,boxxsize)
1280           if (xj.lt.0) xj=xj+boxxsize
1281           yj=mod(yj,boxysize)
1282           if (yj.lt.0) yj=yj+boxysize
1283           zj=mod(zj,boxzsize)
1284           if (zj.lt.0) zj=zj+boxzsize
1285        if ((zj.gt.bordlipbot)
1286      &.and.(zj.lt.bordliptop)) then
1287 C the energy transfer exist
1288         if (zj.lt.buflipbot) then
1289 C what fraction I am in
1290          fracinbuf=1.0d0-
1291      &        ((zj-bordlipbot)/lipbufthick)
1292 C lipbufthick is thickenes of lipid buffore
1293          sslipj=sscalelip(fracinbuf)
1294          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1295         elseif (zj.gt.bufliptop) then
1296          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1297          sslipj=sscalelip(fracinbuf)
1298          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1299         else
1300          sslipj=1.0d0
1301          ssgradlipj=0.0
1302         endif
1303        else
1304          sslipj=0.0d0
1305          ssgradlipj=0.0
1306        endif
1307       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1308      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1309       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1310      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1311 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1312 C checking the distance
1313       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1314       xj_safe=xj
1315       yj_safe=yj
1316       zj_safe=zj
1317       subchap=0
1318 C finding the closest
1319       do xshift=-1,1
1320       do yshift=-1,1
1321       do zshift=-1,1
1322           xj=xj_safe+xshift*boxxsize
1323           yj=yj_safe+yshift*boxysize
1324           zj=zj_safe+zshift*boxzsize
1325           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1326           if(dist_temp.lt.dist_init) then
1327             dist_init=dist_temp
1328             xj_temp=xj
1329             yj_temp=yj
1330             zj_temp=zj
1331             subchap=1
1332           endif
1333        enddo
1334        enddo
1335        enddo
1336        if (subchap.eq.1) then
1337           xj=xj_temp-xi
1338           yj=yj_temp-yi
1339           zj=zj_temp-zi
1340        else
1341           xj=xj_safe-xi
1342           yj=yj_safe-yi
1343           zj=zj_safe-zi
1344        endif
1345             dxj=dc_norm(1,nres+j)
1346             dyj=dc_norm(2,nres+j)
1347             dzj=dc_norm(3,nres+j)
1348             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1349             rij=dsqrt(rrij)
1350 C Calculate angle-dependent terms of energy and contributions to their
1351 C derivatives.
1352             call sc_angular
1353             sigsq=1.0D0/sigsq
1354             sig=sig0ij*dsqrt(sigsq)
1355             rij_shift=1.0D0/rij-sig+r0ij
1356 C I hate to put IF's in the loops, but here don't have another choice!!!!
1357             if (rij_shift.le.0.0D0) then
1358               evdw=1.0D20
1359               return
1360             endif
1361             sigder=-sig*sigsq
1362 c---------------------------------------------------------------
1363             rij_shift=1.0D0/rij_shift
1364             fac=rij_shift**expon
1365             e1=fac*fac*aa
1366             e2=fac*bb
1367             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1368             eps2der=evdwij*eps3rt
1369             eps3der=evdwij*eps2rt
1370             fac_augm=rrij**expon
1371             e_augm=augm(itypi,itypj)*fac_augm
1372             evdwij=evdwij*eps2rt*eps3rt
1373             if (bb.gt.0.0d0) then
1374               evdw=evdw+evdwij+e_augm
1375             else
1376               evdw_t=evdw_t+evdwij+e_augm
1377             endif
1378             ij=icant(itypi,itypj)
1379             aux=eps1*eps2rt**2*eps3rt**2
1380 c            if (lprn) then
1381 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1382 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1383 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1384 c     &        restyp(itypi),i,restyp(itypj),j,
1385 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1386 c     &        chi1,chi2,chip1,chip2,
1387 c     &        eps1,eps2rt**2,eps3rt**2,
1388 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1389 c     &        evdwij+e_augm
1390 c            endif
1391             if (calc_grad) then
1392 C Calculate gradient components.
1393             e1=e1*eps1*eps2rt**2*eps3rt**2
1394             fac=-expon*(e1+evdwij)*rij_shift
1395             sigder=fac*sigder
1396             fac=rij*fac-2*expon*rrij*e_augm
1397 C Calculate the radial part of the gradient
1398             gg(1)=xj*fac
1399             gg(2)=yj*fac
1400             gg(3)=zj*fac
1401 C Calculate angular part of the gradient.
1402             call sc_grad
1403             endif
1404           enddo      ! j
1405         enddo        ! iint
1406       enddo          ! i
1407       return
1408       end
1409 C-----------------------------------------------------------------------------
1410       subroutine sc_angular
1411 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1412 C om12. Called by ebp, egb, and egbv.
1413       implicit none
1414       include 'COMMON.CALC'
1415       erij(1)=xj*rij
1416       erij(2)=yj*rij
1417       erij(3)=zj*rij
1418       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1419       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1420       om12=dxi*dxj+dyi*dyj+dzi*dzj
1421       chiom12=chi12*om12
1422 C Calculate eps1(om12) and its derivative in om12
1423       faceps1=1.0D0-om12*chiom12
1424       faceps1_inv=1.0D0/faceps1
1425       eps1=dsqrt(faceps1_inv)
1426 C Following variable is eps1*deps1/dom12
1427       eps1_om12=faceps1_inv*chiom12
1428 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1429 C and om12.
1430       om1om2=om1*om2
1431       chiom1=chi1*om1
1432       chiom2=chi2*om2
1433       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1434       sigsq=1.0D0-facsig*faceps1_inv
1435       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1436       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1437       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1438 C Calculate eps2 and its derivatives in om1, om2, and om12.
1439       chipom1=chip1*om1
1440       chipom2=chip2*om2
1441       chipom12=chip12*om12
1442       facp=1.0D0-om12*chipom12
1443       facp_inv=1.0D0/facp
1444       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1445 C Following variable is the square root of eps2
1446       eps2rt=1.0D0-facp1*facp_inv
1447 C Following three variables are the derivatives of the square root of eps
1448 C in om1, om2, and om12.
1449       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1450       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1451       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1452 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1453       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1454 C Calculate whole angle-dependent part of epsilon and contributions
1455 C to its derivatives
1456       return
1457       end
1458 C----------------------------------------------------------------------------
1459       subroutine sc_grad
1460       implicit real*8 (a-h,o-z)
1461       include 'DIMENSIONS'
1462       include 'sizesclu.dat'
1463       include 'COMMON.CHAIN'
1464       include 'COMMON.DERIV'
1465       include 'COMMON.CALC'
1466       double precision dcosom1(3),dcosom2(3)
1467       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1468       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1469       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1470      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1471       do k=1,3
1472         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1473         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1474       enddo
1475       do k=1,3
1476         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1477       enddo
1478       do k=1,3
1479         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1480      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1481      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1482         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipi(k)
1483      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1484      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1485       enddo
1486 C
1487 C Calculate the components of the gradient in DC and X
1488 C
1489       do k=i,j-1
1490         do l=1,3
1491           gvdwc(l,k)=gvdwc(l,k)+gg(l)+gg_lipi(l)
1492         enddo
1493       enddo
1494       do l=1,3
1495          gvdwc(l,j)=gvdwc(l,j)+gg_lipj(l)
1496       enddo
1497       return
1498       end
1499 c------------------------------------------------------------------------------
1500       subroutine vec_and_deriv
1501       implicit real*8 (a-h,o-z)
1502       include 'DIMENSIONS'
1503       include 'sizesclu.dat'
1504       include 'COMMON.IOUNITS'
1505       include 'COMMON.GEO'
1506       include 'COMMON.VAR'
1507       include 'COMMON.LOCAL'
1508       include 'COMMON.CHAIN'
1509       include 'COMMON.VECTORS'
1510       include 'COMMON.DERIV'
1511       include 'COMMON.INTERACT'
1512       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1513 C Compute the local reference systems. For reference system (i), the
1514 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1515 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1516       do i=1,nres-1
1517 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1518           if (i.eq.nres-1) then
1519 C Case of the last full residue
1520 C Compute the Z-axis
1521             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1522             costh=dcos(pi-theta(nres))
1523             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1524             do k=1,3
1525               uz(k,i)=fac*uz(k,i)
1526             enddo
1527             if (calc_grad) then
1528 C Compute the derivatives of uz
1529             uzder(1,1,1)= 0.0d0
1530             uzder(2,1,1)=-dc_norm(3,i-1)
1531             uzder(3,1,1)= dc_norm(2,i-1)
1532             uzder(1,2,1)= dc_norm(3,i-1)
1533             uzder(2,2,1)= 0.0d0
1534             uzder(3,2,1)=-dc_norm(1,i-1)
1535             uzder(1,3,1)=-dc_norm(2,i-1)
1536             uzder(2,3,1)= dc_norm(1,i-1)
1537             uzder(3,3,1)= 0.0d0
1538             uzder(1,1,2)= 0.0d0
1539             uzder(2,1,2)= dc_norm(3,i)
1540             uzder(3,1,2)=-dc_norm(2,i)
1541             uzder(1,2,2)=-dc_norm(3,i)
1542             uzder(2,2,2)= 0.0d0
1543             uzder(3,2,2)= dc_norm(1,i)
1544             uzder(1,3,2)= dc_norm(2,i)
1545             uzder(2,3,2)=-dc_norm(1,i)
1546             uzder(3,3,2)= 0.0d0
1547             endif
1548 C Compute the Y-axis
1549             facy=fac
1550             do k=1,3
1551               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1552             enddo
1553             if (calc_grad) then
1554 C Compute the derivatives of uy
1555             do j=1,3
1556               do k=1,3
1557                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1558      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1559                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1560               enddo
1561               uyder(j,j,1)=uyder(j,j,1)-costh
1562               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1563             enddo
1564             do j=1,2
1565               do k=1,3
1566                 do l=1,3
1567                   uygrad(l,k,j,i)=uyder(l,k,j)
1568                   uzgrad(l,k,j,i)=uzder(l,k,j)
1569                 enddo
1570               enddo
1571             enddo
1572             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1573             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1574             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1575             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1576             endif
1577           else
1578 C Other residues
1579 C Compute the Z-axis
1580             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1581             costh=dcos(pi-theta(i+2))
1582             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1583             do k=1,3
1584               uz(k,i)=fac*uz(k,i)
1585             enddo
1586             if (calc_grad) then
1587 C Compute the derivatives of uz
1588             uzder(1,1,1)= 0.0d0
1589             uzder(2,1,1)=-dc_norm(3,i+1)
1590             uzder(3,1,1)= dc_norm(2,i+1)
1591             uzder(1,2,1)= dc_norm(3,i+1)
1592             uzder(2,2,1)= 0.0d0
1593             uzder(3,2,1)=-dc_norm(1,i+1)
1594             uzder(1,3,1)=-dc_norm(2,i+1)
1595             uzder(2,3,1)= dc_norm(1,i+1)
1596             uzder(3,3,1)= 0.0d0
1597             uzder(1,1,2)= 0.0d0
1598             uzder(2,1,2)= dc_norm(3,i)
1599             uzder(3,1,2)=-dc_norm(2,i)
1600             uzder(1,2,2)=-dc_norm(3,i)
1601             uzder(2,2,2)= 0.0d0
1602             uzder(3,2,2)= dc_norm(1,i)
1603             uzder(1,3,2)= dc_norm(2,i)
1604             uzder(2,3,2)=-dc_norm(1,i)
1605             uzder(3,3,2)= 0.0d0
1606             endif
1607 C Compute the Y-axis
1608             facy=fac
1609             do k=1,3
1610               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1611             enddo
1612             if (calc_grad) then
1613 C Compute the derivatives of uy
1614             do j=1,3
1615               do k=1,3
1616                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1617      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1618                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1619               enddo
1620               uyder(j,j,1)=uyder(j,j,1)-costh
1621               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1622             enddo
1623             do j=1,2
1624               do k=1,3
1625                 do l=1,3
1626                   uygrad(l,k,j,i)=uyder(l,k,j)
1627                   uzgrad(l,k,j,i)=uzder(l,k,j)
1628                 enddo
1629               enddo
1630             enddo
1631             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1632             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1633             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1634             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1635           endif
1636           endif
1637       enddo
1638       if (calc_grad) then
1639       do i=1,nres-1
1640         vbld_inv_temp(1)=vbld_inv(i+1)
1641         if (i.lt.nres-1) then
1642           vbld_inv_temp(2)=vbld_inv(i+2)
1643         else
1644           vbld_inv_temp(2)=vbld_inv(i)
1645         endif
1646         do j=1,2
1647           do k=1,3
1648             do l=1,3
1649               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1650               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1651             enddo
1652           enddo
1653         enddo
1654       enddo
1655       endif
1656       return
1657       end
1658 C-----------------------------------------------------------------------------
1659       subroutine vec_and_deriv_test
1660       implicit real*8 (a-h,o-z)
1661       include 'DIMENSIONS'
1662       include 'sizesclu.dat'
1663       include 'COMMON.IOUNITS'
1664       include 'COMMON.GEO'
1665       include 'COMMON.VAR'
1666       include 'COMMON.LOCAL'
1667       include 'COMMON.CHAIN'
1668       include 'COMMON.VECTORS'
1669       dimension uyder(3,3,2),uzder(3,3,2)
1670 C Compute the local reference systems. For reference system (i), the
1671 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1672 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1673       do i=1,nres-1
1674           if (i.eq.nres-1) then
1675 C Case of the last full residue
1676 C Compute the Z-axis
1677             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1678             costh=dcos(pi-theta(nres))
1679             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1680 c            write (iout,*) 'fac',fac,
1681 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1682             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1683             do k=1,3
1684               uz(k,i)=fac*uz(k,i)
1685             enddo
1686 C Compute the derivatives of uz
1687             uzder(1,1,1)= 0.0d0
1688             uzder(2,1,1)=-dc_norm(3,i-1)
1689             uzder(3,1,1)= dc_norm(2,i-1)
1690             uzder(1,2,1)= dc_norm(3,i-1)
1691             uzder(2,2,1)= 0.0d0
1692             uzder(3,2,1)=-dc_norm(1,i-1)
1693             uzder(1,3,1)=-dc_norm(2,i-1)
1694             uzder(2,3,1)= dc_norm(1,i-1)
1695             uzder(3,3,1)= 0.0d0
1696             uzder(1,1,2)= 0.0d0
1697             uzder(2,1,2)= dc_norm(3,i)
1698             uzder(3,1,2)=-dc_norm(2,i)
1699             uzder(1,2,2)=-dc_norm(3,i)
1700             uzder(2,2,2)= 0.0d0
1701             uzder(3,2,2)= dc_norm(1,i)
1702             uzder(1,3,2)= dc_norm(2,i)
1703             uzder(2,3,2)=-dc_norm(1,i)
1704             uzder(3,3,2)= 0.0d0
1705 C Compute the Y-axis
1706             do k=1,3
1707               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1708             enddo
1709             facy=fac
1710             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1711      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1712      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1713             do k=1,3
1714 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1715               uy(k,i)=
1716 c     &        facy*(
1717      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1718      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1719 c     &        )
1720             enddo
1721 c            write (iout,*) 'facy',facy,
1722 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1723             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1724             do k=1,3
1725               uy(k,i)=facy*uy(k,i)
1726             enddo
1727 C Compute the derivatives of uy
1728             do j=1,3
1729               do k=1,3
1730                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1731      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1732                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1733               enddo
1734 c              uyder(j,j,1)=uyder(j,j,1)-costh
1735 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1736               uyder(j,j,1)=uyder(j,j,1)
1737      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1738               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1739      &          +uyder(j,j,2)
1740             enddo
1741             do j=1,2
1742               do k=1,3
1743                 do l=1,3
1744                   uygrad(l,k,j,i)=uyder(l,k,j)
1745                   uzgrad(l,k,j,i)=uzder(l,k,j)
1746                 enddo
1747               enddo
1748             enddo
1749             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1750             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1751             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1752             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1753           else
1754 C Other residues
1755 C Compute the Z-axis
1756             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1757             costh=dcos(pi-theta(i+2))
1758             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1759             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1760             do k=1,3
1761               uz(k,i)=fac*uz(k,i)
1762             enddo
1763 C Compute the derivatives of uz
1764             uzder(1,1,1)= 0.0d0
1765             uzder(2,1,1)=-dc_norm(3,i+1)
1766             uzder(3,1,1)= dc_norm(2,i+1)
1767             uzder(1,2,1)= dc_norm(3,i+1)
1768             uzder(2,2,1)= 0.0d0
1769             uzder(3,2,1)=-dc_norm(1,i+1)
1770             uzder(1,3,1)=-dc_norm(2,i+1)
1771             uzder(2,3,1)= dc_norm(1,i+1)
1772             uzder(3,3,1)= 0.0d0
1773             uzder(1,1,2)= 0.0d0
1774             uzder(2,1,2)= dc_norm(3,i)
1775             uzder(3,1,2)=-dc_norm(2,i)
1776             uzder(1,2,2)=-dc_norm(3,i)
1777             uzder(2,2,2)= 0.0d0
1778             uzder(3,2,2)= dc_norm(1,i)
1779             uzder(1,3,2)= dc_norm(2,i)
1780             uzder(2,3,2)=-dc_norm(1,i)
1781             uzder(3,3,2)= 0.0d0
1782 C Compute the Y-axis
1783             facy=fac
1784             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1785      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1786      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1787             do k=1,3
1788 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1789               uy(k,i)=
1790 c     &        facy*(
1791      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1792      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1793 c     &        )
1794             enddo
1795 c            write (iout,*) 'facy',facy,
1796 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1797             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1798             do k=1,3
1799               uy(k,i)=facy*uy(k,i)
1800             enddo
1801 C Compute the derivatives of uy
1802             do j=1,3
1803               do k=1,3
1804                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1805      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1806                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1807               enddo
1808 c              uyder(j,j,1)=uyder(j,j,1)-costh
1809 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1810               uyder(j,j,1)=uyder(j,j,1)
1811      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1812               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1813      &          +uyder(j,j,2)
1814             enddo
1815             do j=1,2
1816               do k=1,3
1817                 do l=1,3
1818                   uygrad(l,k,j,i)=uyder(l,k,j)
1819                   uzgrad(l,k,j,i)=uzder(l,k,j)
1820                 enddo
1821               enddo
1822             enddo
1823             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1824             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1825             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1826             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1827           endif
1828       enddo
1829       do i=1,nres-1
1830         do j=1,2
1831           do k=1,3
1832             do l=1,3
1833               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1834               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1835             enddo
1836           enddo
1837         enddo
1838       enddo
1839       return
1840       end
1841 C-----------------------------------------------------------------------------
1842       subroutine check_vecgrad
1843       implicit real*8 (a-h,o-z)
1844       include 'DIMENSIONS'
1845       include 'sizesclu.dat'
1846       include 'COMMON.IOUNITS'
1847       include 'COMMON.GEO'
1848       include 'COMMON.VAR'
1849       include 'COMMON.LOCAL'
1850       include 'COMMON.CHAIN'
1851       include 'COMMON.VECTORS'
1852       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1853       dimension uyt(3,maxres),uzt(3,maxres)
1854       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1855       double precision delta /1.0d-7/
1856       call vec_and_deriv
1857 cd      do i=1,nres
1858 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1859 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1860 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1861 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1862 cd     &     (dc_norm(if90,i),if90=1,3)
1863 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1864 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1865 cd          write(iout,'(a)')
1866 cd      enddo
1867       do i=1,nres
1868         do j=1,2
1869           do k=1,3
1870             do l=1,3
1871               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1872               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1873             enddo
1874           enddo
1875         enddo
1876       enddo
1877       call vec_and_deriv
1878       do i=1,nres
1879         do j=1,3
1880           uyt(j,i)=uy(j,i)
1881           uzt(j,i)=uz(j,i)
1882         enddo
1883       enddo
1884       do i=1,nres
1885 cd        write (iout,*) 'i=',i
1886         do k=1,3
1887           erij(k)=dc_norm(k,i)
1888         enddo
1889         do j=1,3
1890           do k=1,3
1891             dc_norm(k,i)=erij(k)
1892           enddo
1893           dc_norm(j,i)=dc_norm(j,i)+delta
1894 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1895 c          do k=1,3
1896 c            dc_norm(k,i)=dc_norm(k,i)/fac
1897 c          enddo
1898 c          write (iout,*) (dc_norm(k,i),k=1,3)
1899 c          write (iout,*) (erij(k),k=1,3)
1900           call vec_and_deriv
1901           do k=1,3
1902             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1903             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1904             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1905             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1906           enddo
1907 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1908 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1909 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1910         enddo
1911         do k=1,3
1912           dc_norm(k,i)=erij(k)
1913         enddo
1914 cd        do k=1,3
1915 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1916 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1917 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1918 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1919 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1920 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1921 cd          write (iout,'(a)')
1922 cd        enddo
1923       enddo
1924       return
1925       end
1926 C--------------------------------------------------------------------------
1927       subroutine set_matrices
1928       implicit real*8 (a-h,o-z)
1929       include 'DIMENSIONS'
1930       include 'sizesclu.dat'
1931       include 'COMMON.IOUNITS'
1932       include 'COMMON.GEO'
1933       include 'COMMON.VAR'
1934       include 'COMMON.LOCAL'
1935       include 'COMMON.CHAIN'
1936       include 'COMMON.DERIV'
1937       include 'COMMON.INTERACT'
1938       include 'COMMON.CONTACTS'
1939       include 'COMMON.TORSION'
1940       include 'COMMON.VECTORS'
1941       include 'COMMON.FFIELD'
1942       double precision auxvec(2),auxmat(2,2)
1943 C
1944 C Compute the virtual-bond-torsional-angle dependent quantities needed
1945 C to calculate the el-loc multibody terms of various order.
1946 C
1947       do i=3,nres+1
1948         if (i .lt. nres+1) then
1949           sin1=dsin(phi(i))
1950           cos1=dcos(phi(i))
1951           sintab(i-2)=sin1
1952           costab(i-2)=cos1
1953           obrot(1,i-2)=cos1
1954           obrot(2,i-2)=sin1
1955           sin2=dsin(2*phi(i))
1956           cos2=dcos(2*phi(i))
1957           sintab2(i-2)=sin2
1958           costab2(i-2)=cos2
1959           obrot2(1,i-2)=cos2
1960           obrot2(2,i-2)=sin2
1961           Ug(1,1,i-2)=-cos1
1962           Ug(1,2,i-2)=-sin1
1963           Ug(2,1,i-2)=-sin1
1964           Ug(2,2,i-2)= cos1
1965           Ug2(1,1,i-2)=-cos2
1966           Ug2(1,2,i-2)=-sin2
1967           Ug2(2,1,i-2)=-sin2
1968           Ug2(2,2,i-2)= cos2
1969         else
1970           costab(i-2)=1.0d0
1971           sintab(i-2)=0.0d0
1972           obrot(1,i-2)=1.0d0
1973           obrot(2,i-2)=0.0d0
1974           obrot2(1,i-2)=0.0d0
1975           obrot2(2,i-2)=0.0d0
1976           Ug(1,1,i-2)=1.0d0
1977           Ug(1,2,i-2)=0.0d0
1978           Ug(2,1,i-2)=0.0d0
1979           Ug(2,2,i-2)=1.0d0
1980           Ug2(1,1,i-2)=0.0d0
1981           Ug2(1,2,i-2)=0.0d0
1982           Ug2(2,1,i-2)=0.0d0
1983           Ug2(2,2,i-2)=0.0d0
1984         endif
1985         if (i .gt. 3 .and. i .lt. nres+1) then
1986           obrot_der(1,i-2)=-sin1
1987           obrot_der(2,i-2)= cos1
1988           Ugder(1,1,i-2)= sin1
1989           Ugder(1,2,i-2)=-cos1
1990           Ugder(2,1,i-2)=-cos1
1991           Ugder(2,2,i-2)=-sin1
1992           dwacos2=cos2+cos2
1993           dwasin2=sin2+sin2
1994           obrot2_der(1,i-2)=-dwasin2
1995           obrot2_der(2,i-2)= dwacos2
1996           Ug2der(1,1,i-2)= dwasin2
1997           Ug2der(1,2,i-2)=-dwacos2
1998           Ug2der(2,1,i-2)=-dwacos2
1999           Ug2der(2,2,i-2)=-dwasin2
2000         else
2001           obrot_der(1,i-2)=0.0d0
2002           obrot_der(2,i-2)=0.0d0
2003           Ugder(1,1,i-2)=0.0d0
2004           Ugder(1,2,i-2)=0.0d0
2005           Ugder(2,1,i-2)=0.0d0
2006           Ugder(2,2,i-2)=0.0d0
2007           obrot2_der(1,i-2)=0.0d0
2008           obrot2_der(2,i-2)=0.0d0
2009           Ug2der(1,1,i-2)=0.0d0
2010           Ug2der(1,2,i-2)=0.0d0
2011           Ug2der(2,1,i-2)=0.0d0
2012           Ug2der(2,2,i-2)=0.0d0
2013         endif
2014         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2015           if (itype(i-2).le.ntyp) then
2016             iti = itortyp(itype(i-2))
2017           else
2018             iti=ntortyp+1
2019           endif
2020         else
2021           iti=ntortyp+1
2022         endif
2023         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2024           if (itype(i-1).le.ntyp) then
2025             iti1 = itortyp(itype(i-1))
2026           else
2027             iti1=ntortyp+1
2028           endif
2029         else
2030           iti1=ntortyp+1
2031         endif
2032 cd        write (iout,*) '*******i',i,' iti1',iti
2033 cd        write (iout,*) 'b1',b1(:,iti)
2034 cd        write (iout,*) 'b2',b2(:,iti)
2035 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2036 c        print *,"itilde1 i iti iti1",i,iti,iti1
2037         if (i .gt. iatel_s+2) then
2038           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2039           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2040           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2041           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2042           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2043           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2044           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2045         else
2046           do k=1,2
2047             Ub2(k,i-2)=0.0d0
2048             Ctobr(k,i-2)=0.0d0
2049             Dtobr2(k,i-2)=0.0d0
2050             do l=1,2
2051               EUg(l,k,i-2)=0.0d0
2052               CUg(l,k,i-2)=0.0d0
2053               DUg(l,k,i-2)=0.0d0
2054               DtUg2(l,k,i-2)=0.0d0
2055             enddo
2056           enddo
2057         endif
2058 c        print *,"itilde2 i iti iti1",i,iti,iti1
2059         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2060         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2061         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2062         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2063         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2064         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2065         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2066 c        print *,"itilde3 i iti iti1",i,iti,iti1
2067         do k=1,2
2068           muder(k,i-2)=Ub2der(k,i-2)
2069         enddo
2070         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2071           if (itype(i-1).le.ntyp) then
2072             iti1 = itortyp(itype(i-1))
2073           else
2074             iti1=ntortyp+1
2075           endif
2076         else
2077           iti1=ntortyp+1
2078         endif
2079         do k=1,2
2080           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2081         enddo
2082 C Vectors and matrices dependent on a single virtual-bond dihedral.
2083         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2084         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2085         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2086         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2087         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2088         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2089         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2090         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2091         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2092 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2093 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2094       enddo
2095 C Matrices dependent on two consecutive virtual-bond dihedrals.
2096 C The order of matrices is from left to right.
2097       do i=2,nres-1
2098         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2099         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2100         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2101         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2102         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2103         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2104         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2105         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2106       enddo
2107 cd      do i=1,nres
2108 cd        iti = itortyp(itype(i))
2109 cd        write (iout,*) i
2110 cd        do j=1,2
2111 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2112 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2113 cd        enddo
2114 cd      enddo
2115       return
2116       end
2117 C--------------------------------------------------------------------------
2118       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2119 C
2120 C This subroutine calculates the average interaction energy and its gradient
2121 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2122 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2123 C The potential depends both on the distance of peptide-group centers and on
2124 C the orientation of the CA-CA virtual bonds.
2125 C
2126       implicit real*8 (a-h,o-z)
2127       include 'DIMENSIONS'
2128       include 'sizesclu.dat'
2129       include 'COMMON.CONTROL'
2130       include 'COMMON.IOUNITS'
2131       include 'COMMON.GEO'
2132       include 'COMMON.VAR'
2133       include 'COMMON.LOCAL'
2134       include 'COMMON.CHAIN'
2135       include 'COMMON.DERIV'
2136       include 'COMMON.INTERACT'
2137       include 'COMMON.CONTACTS'
2138       include 'COMMON.TORSION'
2139       include 'COMMON.VECTORS'
2140       include 'COMMON.FFIELD'
2141       include 'COMMON.SHIELD'
2142
2143       integer xshift,yshift,zshift
2144       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2145      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2146       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2147      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2148       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2149 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2150       double precision scal_el /0.5d0/
2151 C 12/13/98
2152 C 13-go grudnia roku pamietnego...
2153       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2154      &                   0.0d0,1.0d0,0.0d0,
2155      &                   0.0d0,0.0d0,1.0d0/
2156 cd      write(iout,*) 'In EELEC'
2157 cd      do i=1,nloctyp
2158 cd        write(iout,*) 'Type',i
2159 cd        write(iout,*) 'B1',B1(:,i)
2160 cd        write(iout,*) 'B2',B2(:,i)
2161 cd        write(iout,*) 'CC',CC(:,:,i)
2162 cd        write(iout,*) 'DD',DD(:,:,i)
2163 cd        write(iout,*) 'EE',EE(:,:,i)
2164 cd      enddo
2165 cd      call check_vecgrad
2166 cd      stop
2167       if (icheckgrad.eq.1) then
2168         do i=1,nres-1
2169           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2170           do k=1,3
2171             dc_norm(k,i)=dc(k,i)*fac
2172           enddo
2173 c          write (iout,*) 'i',i,' fac',fac
2174         enddo
2175       endif
2176       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2177      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2178      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2179 cd      if (wel_loc.gt.0.0d0) then
2180         if (icheckgrad.eq.1) then
2181         call vec_and_deriv_test
2182         else
2183         call vec_and_deriv
2184         endif
2185         call set_matrices
2186       endif
2187 cd      do i=1,nres-1
2188 cd        write (iout,*) 'i=',i
2189 cd        do k=1,3
2190 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2191 cd        enddo
2192 cd        do k=1,3
2193 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2194 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2195 cd        enddo
2196 cd      enddo
2197       num_conti_hb=0
2198       ees=0.0D0
2199       evdw1=0.0D0
2200       eel_loc=0.0d0
2201       eello_turn3=0.0d0
2202       eello_turn4=0.0d0
2203       ind=0
2204       do i=1,nres
2205         num_cont_hb(i)=0
2206       enddo
2207 cd      print '(a)','Enter EELEC'
2208 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2209       do i=1,nres
2210         gel_loc_loc(i)=0.0d0
2211         gcorr_loc(i)=0.0d0
2212       enddo
2213       do i=iatel_s,iatel_e
2214 cAna           if (i.le.1) cycle
2215            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2216 cAna     &  .or. ((i+2).gt.nres)
2217 cAna     &  .or. ((i-1).le.0)
2218 cAna     &  .or. itype(i+2).eq.ntyp1
2219 cAna     &  .or. itype(i-1).eq.ntyp1
2220      &) cycle
2221 C         endif
2222         if (itel(i).eq.0) goto 1215
2223         dxi=dc(1,i)
2224         dyi=dc(2,i)
2225         dzi=dc(3,i)
2226         dx_normi=dc_norm(1,i)
2227         dy_normi=dc_norm(2,i)
2228         dz_normi=dc_norm(3,i)
2229         xmedi=c(1,i)+0.5d0*dxi
2230         ymedi=c(2,i)+0.5d0*dyi
2231         zmedi=c(3,i)+0.5d0*dzi
2232           xmedi=mod(xmedi,boxxsize)
2233           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2234           ymedi=mod(ymedi,boxysize)
2235           if (ymedi.lt.0) ymedi=ymedi+boxysize
2236           zmedi=mod(zmedi,boxzsize)
2237           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2238         num_conti=0
2239 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2240         do j=ielstart(i),ielend(i)
2241 cAna          if (j.le.1) cycle
2242           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2243 cAna     & .or.((j+2).gt.nres)
2244 cAna     & .or.((j-1).le.0)
2245 cAna     & .or.itype(j+2).eq.ntyp1
2246 cAna     & .or.itype(j-1).eq.ntyp1
2247      &) cycle
2248 C         endif
2249           if (itel(j).eq.0) goto 1216
2250           ind=ind+1
2251           iteli=itel(i)
2252           itelj=itel(j)
2253           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2254           aaa=app(iteli,itelj)
2255           bbb=bpp(iteli,itelj)
2256 C Diagnostics only!!!
2257 c         aaa=0.0D0
2258 c         bbb=0.0D0
2259 c         ael6i=0.0D0
2260 c         ael3i=0.0D0
2261 C End diagnostics
2262           ael6i=ael6(iteli,itelj)
2263           ael3i=ael3(iteli,itelj)
2264           dxj=dc(1,j)
2265           dyj=dc(2,j)
2266           dzj=dc(3,j)
2267           dx_normj=dc_norm(1,j)
2268           dy_normj=dc_norm(2,j)
2269           dz_normj=dc_norm(3,j)
2270           xj=c(1,j)+0.5D0*dxj
2271           yj=c(2,j)+0.5D0*dyj
2272           zj=c(3,j)+0.5D0*dzj
2273          xj=mod(xj,boxxsize)
2274           if (xj.lt.0) xj=xj+boxxsize
2275           yj=mod(yj,boxysize)
2276           if (yj.lt.0) yj=yj+boxysize
2277           zj=mod(zj,boxzsize)
2278           if (zj.lt.0) zj=zj+boxzsize
2279       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2280       xj_safe=xj
2281       yj_safe=yj
2282       zj_safe=zj
2283       isubchap=0
2284       do xshift=-1,1
2285       do yshift=-1,1
2286       do zshift=-1,1
2287           xj=xj_safe+xshift*boxxsize
2288           yj=yj_safe+yshift*boxysize
2289           zj=zj_safe+zshift*boxzsize
2290           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2291           if(dist_temp.lt.dist_init) then
2292             dist_init=dist_temp
2293             xj_temp=xj
2294             yj_temp=yj
2295             zj_temp=zj
2296             isubchap=1
2297           endif
2298        enddo
2299        enddo
2300        enddo
2301        if (isubchap.eq.1) then
2302           xj=xj_temp-xmedi
2303           yj=yj_temp-ymedi
2304           zj=zj_temp-zmedi
2305        else
2306           xj=xj_safe-xmedi
2307           yj=yj_safe-ymedi
2308           zj=zj_safe-zmedi
2309        endif
2310
2311           rij=xj*xj+yj*yj+zj*zj
2312             sss=sscale(sqrt(rij))
2313             sssgrad=sscagrad(sqrt(rij))
2314           rrmij=1.0D0/rij
2315           rij=dsqrt(rij)
2316           rmij=1.0D0/rij
2317           r3ij=rrmij*rmij
2318           r6ij=r3ij*r3ij
2319           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2320           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2321           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2322           fac=cosa-3.0D0*cosb*cosg
2323           ev1=aaa*r6ij*r6ij
2324 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2325           if (j.eq.i+2) ev1=scal_el*ev1
2326           ev2=bbb*r6ij
2327           fac3=ael6i*r6ij
2328           fac4=ael3i*r3ij
2329           evdwij=ev1+ev2
2330           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2331           el2=fac4*fac
2332           eesij=el1+el2
2333 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2334 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2335           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2336           if (shield_mode.gt.0) then
2337 C          fac_shield(i)=0.4
2338 C          fac_shield(j)=0.6
2339 C#define DEBUG
2340 #ifdef DEBUG
2341           write(iout,*) "ees_compon",i,j,el1,el2,
2342      &    fac_shield(i),fac_shield(j)
2343 #endif
2344 C#undef DEBUG
2345           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2346           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2347           eesij=(el1+el2)
2348           ees=ees+eesij
2349           else
2350           fac_shield(i)=1.0
2351           fac_shield(j)=1.0
2352           eesij=(el1+el2)
2353           ees=ees+eesij
2354           endif
2355 C          ees=ees+eesij
2356           evdw1=evdw1+evdwij*sss
2357 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2358 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2359 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2360 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2361 C
2362 C Calculate contributions to the Cartesian gradient.
2363 C
2364 #ifdef SPLITELE
2365           facvdw=-6*rrmij*(ev1+evdwij)*sss
2366           facel=-3*rrmij*(el1+eesij)
2367           fac1=fac
2368           erij(1)=xj*rmij
2369           erij(2)=yj*rmij
2370           erij(3)=zj*rmij
2371           if (calc_grad) then
2372 *
2373 * Radial derivatives. First process both termini of the fragment (i,j)
2374 *
2375           ggg(1)=facel*xj
2376           ggg(2)=facel*yj
2377           ggg(3)=facel*zj
2378
2379           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2380      &  (shield_mode.gt.0)) then
2381 C          print *,i,j
2382           do ilist=1,ishield_list(i)
2383            iresshield=shield_list(ilist,i)
2384            do k=1,3
2385            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2386      &      *2.0
2387            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2388      &              rlocshield
2389      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2390             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2391 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2392 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2393 C             if (iresshield.gt.i) then
2394 C               do ishi=i+1,iresshield-1
2395 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2396 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2397 C
2398 C              enddo
2399 C             else
2400 C               do ishi=iresshield,i
2401 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2402 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2403 C
2404 C               enddo
2405 C              endif
2406 C           enddo
2407 C          enddo
2408            enddo
2409           enddo
2410           do ilist=1,ishield_list(j)
2411            iresshield=shield_list(ilist,j)
2412            do k=1,3
2413            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2414      &     *2.0
2415            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2416      &              rlocshield
2417      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2418            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2419            enddo
2420           enddo
2421
2422           do k=1,3
2423             gshieldc(k,i)=gshieldc(k,i)+
2424      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2425             gshieldc(k,j)=gshieldc(k,j)+
2426      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2427             gshieldc(k,i-1)=gshieldc(k,i-1)+
2428      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2429             gshieldc(k,j-1)=gshieldc(k,j-1)+
2430      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2431
2432            enddo
2433            endif
2434
2435           do k=1,3
2436             ghalf=0.5D0*ggg(k)
2437             gelc(k,i)=gelc(k,i)+ghalf
2438             gelc(k,j)=gelc(k,j)+ghalf
2439           enddo
2440 *
2441 * Loop over residues i+1 thru j-1.
2442 *
2443           do k=i+1,j-1
2444             do l=1,3
2445               gelc(l,k)=gelc(l,k)+ggg(l)
2446             enddo
2447           enddo
2448 C          ggg(1)=facvdw*xj
2449 C          ggg(2)=facvdw*yj
2450 C          ggg(3)=facvdw*zj
2451           if (sss.gt.0.0) then
2452           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2453           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2454           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2455           else
2456           ggg(1)=0.0
2457           ggg(2)=0.0
2458           ggg(3)=0.0
2459           endif
2460           do k=1,3
2461             ghalf=0.5D0*ggg(k)
2462             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2463             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2464           enddo
2465 *
2466 * Loop over residues i+1 thru j-1.
2467 *
2468           do k=i+1,j-1
2469             do l=1,3
2470               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2471             enddo
2472           enddo
2473 #else
2474           facvdw=(ev1+evdwij)*sss
2475           facel=el1+eesij
2476           fac1=fac
2477           fac=-3*rrmij*(facvdw+facvdw+facel)
2478           erij(1)=xj*rmij
2479           erij(2)=yj*rmij
2480           erij(3)=zj*rmij
2481           if (calc_grad) then
2482 *
2483 * Radial derivatives. First process both termini of the fragment (i,j)
2484 *
2485           ggg(1)=fac*xj
2486           ggg(2)=fac*yj
2487           ggg(3)=fac*zj
2488           do k=1,3
2489             ghalf=0.5D0*ggg(k)
2490             gelc(k,i)=gelc(k,i)+ghalf
2491             gelc(k,j)=gelc(k,j)+ghalf
2492           enddo
2493 *
2494 * Loop over residues i+1 thru j-1.
2495 *
2496           do k=i+1,j-1
2497             do l=1,3
2498               gelc(l,k)=gelc(l,k)+ggg(l)
2499             enddo
2500           enddo
2501 #endif
2502 *
2503 * Angular part
2504 *
2505           ecosa=2.0D0*fac3*fac1+fac4
2506           fac4=-3.0D0*fac4
2507           fac3=-6.0D0*fac3
2508           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2509           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2510           do k=1,3
2511             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2512             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2513           enddo
2514 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2515 cd   &          (dcosg(k),k=1,3)
2516           do k=1,3
2517             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2518      &      *fac_shield(i)**2*fac_shield(j)**2
2519           enddo
2520           do k=1,3
2521             ghalf=0.5D0*ggg(k)
2522             gelc(k,i)=gelc(k,i)+ghalf
2523      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2524      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2525      &           *fac_shield(i)**2*fac_shield(j)**2
2526
2527             gelc(k,j)=gelc(k,j)+ghalf
2528      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2529      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2530      &           *fac_shield(i)**2*fac_shield(j)**2
2531           enddo
2532           do k=i+1,j-1
2533             do l=1,3
2534               gelc(l,k)=gelc(l,k)+ggg(l)
2535             enddo
2536           enddo
2537           endif
2538
2539           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2540      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2541      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2542 C
2543 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2544 C   energy of a peptide unit is assumed in the form of a second-order
2545 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2546 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2547 C   are computed for EVERY pair of non-contiguous peptide groups.
2548 C
2549           if (j.lt.nres-1) then
2550             j1=j+1
2551             j2=j-1
2552           else
2553             j1=j-1
2554             j2=j-2
2555           endif
2556           kkk=0
2557           do k=1,2
2558             do l=1,2
2559               kkk=kkk+1
2560               muij(kkk)=mu(k,i)*mu(l,j)
2561             enddo
2562           enddo
2563 cd         write (iout,*) 'EELEC: i',i,' j',j
2564 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2565 cd          write(iout,*) 'muij',muij
2566           ury=scalar(uy(1,i),erij)
2567           urz=scalar(uz(1,i),erij)
2568           vry=scalar(uy(1,j),erij)
2569           vrz=scalar(uz(1,j),erij)
2570           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2571           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2572           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2573           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2574 C For diagnostics only
2575 cd          a22=1.0d0
2576 cd          a23=1.0d0
2577 cd          a32=1.0d0
2578 cd          a33=1.0d0
2579           fac=dsqrt(-ael6i)*r3ij
2580 cd          write (2,*) 'fac=',fac
2581 C For diagnostics only
2582 cd          fac=1.0d0
2583           a22=a22*fac
2584           a23=a23*fac
2585           a32=a32*fac
2586           a33=a33*fac
2587 cd          write (iout,'(4i5,4f10.5)')
2588 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2589 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2590 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2591 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2592 cd          write (iout,'(4f10.5)')
2593 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2594 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2595 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2596 cd           write (iout,'(2i3,9f10.5/)') i,j,
2597 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2598           if (calc_grad) then
2599 C Derivatives of the elements of A in virtual-bond vectors
2600           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2601 cd          do k=1,3
2602 cd            do l=1,3
2603 cd              erder(k,l)=0.0d0
2604 cd            enddo
2605 cd          enddo
2606           do k=1,3
2607             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2608             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2609             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2610             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2611             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2612             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2613             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2614             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2615             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2616             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2617             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2618             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2619           enddo
2620 cd          do k=1,3
2621 cd            do l=1,3
2622 cd              uryg(k,l)=0.0d0
2623 cd              urzg(k,l)=0.0d0
2624 cd              vryg(k,l)=0.0d0
2625 cd              vrzg(k,l)=0.0d0
2626 cd            enddo
2627 cd          enddo
2628 C Compute radial contributions to the gradient
2629           facr=-3.0d0*rrmij
2630           a22der=a22*facr
2631           a23der=a23*facr
2632           a32der=a32*facr
2633           a33der=a33*facr
2634 cd          a22der=0.0d0
2635 cd          a23der=0.0d0
2636 cd          a32der=0.0d0
2637 cd          a33der=0.0d0
2638           agg(1,1)=a22der*xj
2639           agg(2,1)=a22der*yj
2640           agg(3,1)=a22der*zj
2641           agg(1,2)=a23der*xj
2642           agg(2,2)=a23der*yj
2643           agg(3,2)=a23der*zj
2644           agg(1,3)=a32der*xj
2645           agg(2,3)=a32der*yj
2646           agg(3,3)=a32der*zj
2647           agg(1,4)=a33der*xj
2648           agg(2,4)=a33der*yj
2649           agg(3,4)=a33der*zj
2650 C Add the contributions coming from er
2651           fac3=-3.0d0*fac
2652           do k=1,3
2653             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2654             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2655             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2656             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2657           enddo
2658           do k=1,3
2659 C Derivatives in DC(i)
2660             ghalf1=0.5d0*agg(k,1)
2661             ghalf2=0.5d0*agg(k,2)
2662             ghalf3=0.5d0*agg(k,3)
2663             ghalf4=0.5d0*agg(k,4)
2664             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2665      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2666             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2667      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2668             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2669      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2670             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2671      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2672 C Derivatives in DC(i+1)
2673             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2674      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2675             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2676      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2677             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2678      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2679             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2680      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2681 C Derivatives in DC(j)
2682             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2683      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2684             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2685      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2686             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2687      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2688             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2689      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2690 C Derivatives in DC(j+1) or DC(nres-1)
2691             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2692      &      -3.0d0*vryg(k,3)*ury)
2693             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2694      &      -3.0d0*vrzg(k,3)*ury)
2695             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2696      &      -3.0d0*vryg(k,3)*urz)
2697             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2698      &      -3.0d0*vrzg(k,3)*urz)
2699 cd            aggi(k,1)=ghalf1
2700 cd            aggi(k,2)=ghalf2
2701 cd            aggi(k,3)=ghalf3
2702 cd            aggi(k,4)=ghalf4
2703 C Derivatives in DC(i+1)
2704 cd            aggi1(k,1)=agg(k,1)
2705 cd            aggi1(k,2)=agg(k,2)
2706 cd            aggi1(k,3)=agg(k,3)
2707 cd            aggi1(k,4)=agg(k,4)
2708 C Derivatives in DC(j)
2709 cd            aggj(k,1)=ghalf1
2710 cd            aggj(k,2)=ghalf2
2711 cd            aggj(k,3)=ghalf3
2712 cd            aggj(k,4)=ghalf4
2713 C Derivatives in DC(j+1)
2714 cd            aggj1(k,1)=0.0d0
2715 cd            aggj1(k,2)=0.0d0
2716 cd            aggj1(k,3)=0.0d0
2717 cd            aggj1(k,4)=0.0d0
2718             if (j.eq.nres-1 .and. i.lt.j-2) then
2719               do l=1,4
2720                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2721 cd                aggj1(k,l)=agg(k,l)
2722               enddo
2723             endif
2724           enddo
2725           endif
2726 c          goto 11111
2727 C Check the loc-el terms by numerical integration
2728           acipa(1,1)=a22
2729           acipa(1,2)=a23
2730           acipa(2,1)=a32
2731           acipa(2,2)=a33
2732           a22=-a22
2733           a23=-a23
2734           do l=1,2
2735             do k=1,3
2736               agg(k,l)=-agg(k,l)
2737               aggi(k,l)=-aggi(k,l)
2738               aggi1(k,l)=-aggi1(k,l)
2739               aggj(k,l)=-aggj(k,l)
2740               aggj1(k,l)=-aggj1(k,l)
2741             enddo
2742           enddo
2743           if (j.lt.nres-1) then
2744             a22=-a22
2745             a32=-a32
2746             do l=1,3,2
2747               do k=1,3
2748                 agg(k,l)=-agg(k,l)
2749                 aggi(k,l)=-aggi(k,l)
2750                 aggi1(k,l)=-aggi1(k,l)
2751                 aggj(k,l)=-aggj(k,l)
2752                 aggj1(k,l)=-aggj1(k,l)
2753               enddo
2754             enddo
2755           else
2756             a22=-a22
2757             a23=-a23
2758             a32=-a32
2759             a33=-a33
2760             do l=1,4
2761               do k=1,3
2762                 agg(k,l)=-agg(k,l)
2763                 aggi(k,l)=-aggi(k,l)
2764                 aggi1(k,l)=-aggi1(k,l)
2765                 aggj(k,l)=-aggj(k,l)
2766                 aggj1(k,l)=-aggj1(k,l)
2767               enddo
2768             enddo
2769           endif
2770           ENDIF ! WCORR
2771 11111     continue
2772           IF (wel_loc.gt.0.0d0) THEN
2773 C Contribution to the local-electrostatic energy coming from the i-j pair
2774           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2775      &     +a33*muij(4)
2776 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2777 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2778           if (shield_mode.eq.0) then
2779            fac_shield(i)=1.0
2780            fac_shield(j)=1.0
2781 C          else
2782 C           fac_shield(i)=0.4
2783 C           fac_shield(j)=0.6
2784           endif
2785           eel_loc_ij=eel_loc_ij
2786      &    *fac_shield(i)*fac_shield(j)
2787           eel_loc=eel_loc+eel_loc_ij
2788 C Partial derivatives in virtual-bond dihedral angles gamma
2789           if (calc_grad) then
2790           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2791      &  (shield_mode.gt.0)) then
2792 C          print *,i,j
2793
2794           do ilist=1,ishield_list(i)
2795            iresshield=shield_list(ilist,i)
2796            do k=1,3
2797            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2798      &                                          /fac_shield(i)
2799 C     &      *2.0
2800            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2801      &              rlocshield
2802      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2803             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2804      &      +rlocshield
2805            enddo
2806           enddo
2807           do ilist=1,ishield_list(j)
2808            iresshield=shield_list(ilist,j)
2809            do k=1,3
2810            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2811      &                                       /fac_shield(j)
2812 C     &     *2.0
2813            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2814      &              rlocshield
2815      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2816            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2817      &             +rlocshield
2818
2819            enddo
2820           enddo
2821           do k=1,3
2822             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2823      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2824             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2825      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2826             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2827      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2828             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2829      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2830            enddo
2831            endif
2832           if (i.gt.1)
2833      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2834      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2835      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2836      &    *fac_shield(i)*fac_shield(j)
2837           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2838      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2839      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2840      &    *fac_shield(i)*fac_shield(j)
2841
2842 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2843 cd          write(iout,*) 'agg  ',agg
2844 cd          write(iout,*) 'aggi ',aggi
2845 cd          write(iout,*) 'aggi1',aggi1
2846 cd          write(iout,*) 'aggj ',aggj
2847 cd          write(iout,*) 'aggj1',aggj1
2848
2849 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2850           do l=1,3
2851             ggg(l)=agg(l,1)*muij(1)+
2852      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2853      &    *fac_shield(i)*fac_shield(j)
2854
2855           enddo
2856           do k=i+2,j2
2857             do l=1,3
2858               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2859             enddo
2860           enddo
2861 C Remaining derivatives of eello
2862           do l=1,3
2863             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2864      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2865      &    *fac_shield(i)*fac_shield(j)
2866
2867             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2868      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2869      &    *fac_shield(i)*fac_shield(j)
2870
2871             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2872      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2873      &    *fac_shield(i)*fac_shield(j)
2874
2875             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2876      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2877      &    *fac_shield(i)*fac_shield(j)
2878
2879           enddo
2880           endif
2881           ENDIF
2882           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2883 C Contributions from turns
2884             a_temp(1,1)=a22
2885             a_temp(1,2)=a23
2886             a_temp(2,1)=a32
2887             a_temp(2,2)=a33
2888             call eturn34(i,j,eello_turn3,eello_turn4)
2889           endif
2890 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2891           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2892 C
2893 C Calculate the contact function. The ith column of the array JCONT will
2894 C contain the numbers of atoms that make contacts with the atom I (of numbers
2895 C greater than I). The arrays FACONT and GACONT will contain the values of
2896 C the contact function and its derivative.
2897 c           r0ij=1.02D0*rpp(iteli,itelj)
2898 c           r0ij=1.11D0*rpp(iteli,itelj)
2899             r0ij=2.20D0*rpp(iteli,itelj)
2900 c           r0ij=1.55D0*rpp(iteli,itelj)
2901             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2902             if (fcont.gt.0.0D0) then
2903               num_conti=num_conti+1
2904               if (num_conti.gt.maxconts) then
2905                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2906      &                         ' will skip next contacts for this conf.'
2907               else
2908                 jcont_hb(num_conti,i)=j
2909                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2910      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2911 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2912 C  terms.
2913                 d_cont(num_conti,i)=rij
2914 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2915 C     --- Electrostatic-interaction matrix ---
2916                 a_chuj(1,1,num_conti,i)=a22
2917                 a_chuj(1,2,num_conti,i)=a23
2918                 a_chuj(2,1,num_conti,i)=a32
2919                 a_chuj(2,2,num_conti,i)=a33
2920 C     --- Gradient of rij
2921                 do kkk=1,3
2922                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2923                 enddo
2924 c             if (i.eq.1) then
2925 c                a_chuj(1,1,num_conti,i)=-0.61d0
2926 c                a_chuj(1,2,num_conti,i)= 0.4d0
2927 c                a_chuj(2,1,num_conti,i)= 0.65d0
2928 c                a_chuj(2,2,num_conti,i)= 0.50d0
2929 c             else if (i.eq.2) then
2930 c                a_chuj(1,1,num_conti,i)= 0.0d0
2931 c                a_chuj(1,2,num_conti,i)= 0.0d0
2932 c                a_chuj(2,1,num_conti,i)= 0.0d0
2933 c                a_chuj(2,2,num_conti,i)= 0.0d0
2934 c             endif
2935 C     --- and its gradients
2936 cd                write (iout,*) 'i',i,' j',j
2937 cd                do kkk=1,3
2938 cd                write (iout,*) 'iii 1 kkk',kkk
2939 cd                write (iout,*) agg(kkk,:)
2940 cd                enddo
2941 cd                do kkk=1,3
2942 cd                write (iout,*) 'iii 2 kkk',kkk
2943 cd                write (iout,*) aggi(kkk,:)
2944 cd                enddo
2945 cd                do kkk=1,3
2946 cd                write (iout,*) 'iii 3 kkk',kkk
2947 cd                write (iout,*) aggi1(kkk,:)
2948 cd                enddo
2949 cd                do kkk=1,3
2950 cd                write (iout,*) 'iii 4 kkk',kkk
2951 cd                write (iout,*) aggj(kkk,:)
2952 cd                enddo
2953 cd                do kkk=1,3
2954 cd                write (iout,*) 'iii 5 kkk',kkk
2955 cd                write (iout,*) aggj1(kkk,:)
2956 cd                enddo
2957                 kkll=0
2958                 do k=1,2
2959                   do l=1,2
2960                     kkll=kkll+1
2961                     do m=1,3
2962                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2963                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2964                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2965                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2966                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2967 c                      do mm=1,5
2968 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2969 c                      enddo
2970                     enddo
2971                   enddo
2972                 enddo
2973                 ENDIF
2974                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2975 C Calculate contact energies
2976                 cosa4=4.0D0*cosa
2977                 wij=cosa-3.0D0*cosb*cosg
2978                 cosbg1=cosb+cosg
2979                 cosbg2=cosb-cosg
2980 c               fac3=dsqrt(-ael6i)/r0ij**3
2981                 fac3=dsqrt(-ael6i)*r3ij
2982                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2983                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2984                 if (shield_mode.eq.0) then
2985                 fac_shield(i)=1.0d0
2986                 fac_shield(j)=1.0d0
2987                 else
2988                 ees0plist(num_conti,i)=j
2989 C                fac_shield(i)=0.4d0
2990 C                fac_shield(j)=0.6d0
2991                 endif
2992 c               ees0mij=0.0D0
2993                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2994      &          *fac_shield(i)*fac_shield(j)
2995
2996                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2997      &          *fac_shield(i)*fac_shield(j)
2998
2999 C Diagnostics. Comment out or remove after debugging!
3000 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3001 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3002 c               ees0m(num_conti,i)=0.0D0
3003 C End diagnostics.
3004 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3005 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3006                 facont_hb(num_conti,i)=fcont
3007                 if (calc_grad) then
3008 C Angular derivatives of the contact function
3009                 ees0pij1=fac3/ees0pij
3010                 ees0mij1=fac3/ees0mij
3011                 fac3p=-3.0D0*fac3*rrmij
3012                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3013                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3014 c               ees0mij1=0.0D0
3015                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3016                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3017                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3018                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3019                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3020                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3021                 ecosap=ecosa1+ecosa2
3022                 ecosbp=ecosb1+ecosb2
3023                 ecosgp=ecosg1+ecosg2
3024                 ecosam=ecosa1-ecosa2
3025                 ecosbm=ecosb1-ecosb2
3026                 ecosgm=ecosg1-ecosg2
3027 C Diagnostics
3028 c               ecosap=ecosa1
3029 c               ecosbp=ecosb1
3030 c               ecosgp=ecosg1
3031 c               ecosam=0.0D0
3032 c               ecosbm=0.0D0
3033 c               ecosgm=0.0D0
3034 C End diagnostics
3035                 fprimcont=fprimcont/rij
3036 cd              facont_hb(num_conti,i)=1.0D0
3037 C Following line is for diagnostics.
3038 cd              fprimcont=0.0D0
3039                 do k=1,3
3040                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3041                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3042                 enddo
3043                 do k=1,3
3044                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3045                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3046                 enddo
3047                 gggp(1)=gggp(1)+ees0pijp*xj
3048                 gggp(2)=gggp(2)+ees0pijp*yj
3049                 gggp(3)=gggp(3)+ees0pijp*zj
3050                 gggm(1)=gggm(1)+ees0mijp*xj
3051                 gggm(2)=gggm(2)+ees0mijp*yj
3052                 gggm(3)=gggm(3)+ees0mijp*zj
3053 C Derivatives due to the contact function
3054                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3055                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3056                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3057                 do k=1,3
3058                   ghalfp=0.5D0*gggp(k)
3059                   ghalfm=0.5D0*gggm(k)
3060                   gacontp_hb1(k,num_conti,i)=ghalfp
3061      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3062      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3063      &          *fac_shield(i)*fac_shield(j)
3064
3065                   gacontp_hb2(k,num_conti,i)=ghalfp
3066      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3067      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3068      &          *fac_shield(i)*fac_shield(j)
3069
3070                   gacontp_hb3(k,num_conti,i)=gggp(k)
3071      &          *fac_shield(i)*fac_shield(j)
3072
3073                   gacontm_hb1(k,num_conti,i)=ghalfm
3074      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3075      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3076      &          *fac_shield(i)*fac_shield(j)
3077
3078                   gacontm_hb2(k,num_conti,i)=ghalfm
3079      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3080      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3081      &          *fac_shield(i)*fac_shield(j)
3082
3083                   gacontm_hb3(k,num_conti,i)=gggm(k)
3084      &          *fac_shield(i)*fac_shield(j)
3085
3086                 enddo
3087                 endif
3088 C Diagnostics. Comment out or remove after debugging!
3089 cdiag           do k=1,3
3090 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3091 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3092 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3093 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3094 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3095 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3096 cdiag           enddo
3097               ENDIF ! wcorr
3098               endif  ! num_conti.le.maxconts
3099             endif  ! fcont.gt.0
3100           endif    ! j.gt.i+1
3101  1216     continue
3102         enddo ! j
3103         num_cont_hb(i)=num_conti
3104  1215   continue
3105       enddo   ! i
3106 cd      do i=1,nres
3107 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3108 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3109 cd      enddo
3110 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3111 ccc      eel_loc=eel_loc+eello_turn3
3112       return
3113       end
3114 C-----------------------------------------------------------------------------
3115       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3116 C Third- and fourth-order contributions from turns
3117       implicit real*8 (a-h,o-z)
3118       include 'DIMENSIONS'
3119       include 'sizesclu.dat'
3120       include 'COMMON.IOUNITS'
3121       include 'COMMON.GEO'
3122       include 'COMMON.VAR'
3123       include 'COMMON.LOCAL'
3124       include 'COMMON.CHAIN'
3125       include 'COMMON.DERIV'
3126       include 'COMMON.INTERACT'
3127       include 'COMMON.CONTACTS'
3128       include 'COMMON.TORSION'
3129       include 'COMMON.VECTORS'
3130       include 'COMMON.FFIELD'
3131       include 'COMMON.SHIELD'
3132       include 'COMMON.CONTROL'
3133
3134       dimension ggg(3)
3135       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3136      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3137      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3138       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3139      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3140       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3141       if (j.eq.i+2) then
3142       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3143 C changes suggested by Ana to avoid out of bounds
3144 C     & .or.((i+5).gt.nres)
3145 C     & .or.((i-1).le.0)
3146 C end of changes suggested by Ana
3147      &    .or. itype(i+2).eq.ntyp1
3148      &    .or. itype(i+3).eq.ntyp1
3149 C     &    .or. itype(i+5).eq.ntyp1
3150 C     &    .or. itype(i).eq.ntyp1
3151 C     &    .or. itype(i-1).eq.ntyp1
3152      &    ) goto 179
3153
3154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3155 C
3156 C               Third-order contributions
3157 C
3158 C                 (i+2)o----(i+3)
3159 C                      | |
3160 C                      | |
3161 C                 (i+1)o----i
3162 C
3163 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3164 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3165         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3166         call transpose2(auxmat(1,1),auxmat1(1,1))
3167         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3168         if (shield_mode.eq.0) then
3169         fac_shield(i)=1.0
3170         fac_shield(j)=1.0
3171 C        else
3172 C        fac_shield(i)=0.4
3173 C        fac_shield(j)=0.6
3174         endif
3175         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3176      &  *fac_shield(i)*fac_shield(j)
3177         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3178      &  *fac_shield(i)*fac_shield(j)
3179
3180 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3181 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3182 cd     &    ' eello_turn3_num',4*eello_turn3_num
3183         if (calc_grad) then
3184 C Derivatives in shield mode
3185           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3186      &  (shield_mode.gt.0)) then
3187 C          print *,i,j
3188
3189           do ilist=1,ishield_list(i)
3190            iresshield=shield_list(ilist,i)
3191            do k=1,3
3192            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3193 C     &      *2.0
3194            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3195      &              rlocshield
3196      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3197             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3198      &      +rlocshield
3199            enddo
3200           enddo
3201           do ilist=1,ishield_list(j)
3202            iresshield=shield_list(ilist,j)
3203            do k=1,3
3204            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3205 C     &     *2.0
3206            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3207      &              rlocshield
3208      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3209            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3210      &             +rlocshield
3211
3212            enddo
3213           enddo
3214
3215           do k=1,3
3216             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3217      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3218             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3219      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3220             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3221      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3222             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3223      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3224            enddo
3225            endif
3226
3227 C Derivatives in gamma(i)
3228         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3229         call transpose2(auxmat2(1,1),pizda(1,1))
3230         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3231         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3232      &   *fac_shield(i)*fac_shield(j)
3233
3234 C Derivatives in gamma(i+1)
3235         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3236         call transpose2(auxmat2(1,1),pizda(1,1))
3237         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3238         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3239      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3240      &   *fac_shield(i)*fac_shield(j)
3241
3242 C Cartesian derivatives
3243         do l=1,3
3244           a_temp(1,1)=aggi(l,1)
3245           a_temp(1,2)=aggi(l,2)
3246           a_temp(2,1)=aggi(l,3)
3247           a_temp(2,2)=aggi(l,4)
3248           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3249           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3250      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3251      &   *fac_shield(i)*fac_shield(j)
3252
3253           a_temp(1,1)=aggi1(l,1)
3254           a_temp(1,2)=aggi1(l,2)
3255           a_temp(2,1)=aggi1(l,3)
3256           a_temp(2,2)=aggi1(l,4)
3257           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3258           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3259      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3260      &   *fac_shield(i)*fac_shield(j)
3261
3262           a_temp(1,1)=aggj(l,1)
3263           a_temp(1,2)=aggj(l,2)
3264           a_temp(2,1)=aggj(l,3)
3265           a_temp(2,2)=aggj(l,4)
3266           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3267           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3268      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3269      &   *fac_shield(i)*fac_shield(j)
3270
3271           a_temp(1,1)=aggj1(l,1)
3272           a_temp(1,2)=aggj1(l,2)
3273           a_temp(2,1)=aggj1(l,3)
3274           a_temp(2,2)=aggj1(l,4)
3275           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3276           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3277      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3278      &   *fac_shield(i)*fac_shield(j)
3279
3280         enddo
3281         endif
3282   179 continue
3283       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3284       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3285 C changes suggested by Ana to avoid out of bounds
3286 C     & .or.((i+5).gt.nres)
3287 C     & .or.((i-1).le.0)
3288 C end of changes suggested by Ana
3289      &    .or. itype(i+3).eq.ntyp1
3290      &    .or. itype(i+4).eq.ntyp1
3291 C     &    .or. itype(i+5).eq.ntyp1
3292      &    .or. itype(i).eq.ntyp1
3293 C     &    .or. itype(i-1).eq.ntyp1
3294      &    ) goto 178
3295
3296 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3297 C
3298 C               Fourth-order contributions
3299 C
3300 C                 (i+3)o----(i+4)
3301 C                     /  |
3302 C               (i+2)o   |
3303 C                     \  |
3304 C                 (i+1)o----i
3305 C
3306 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3307 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3308         iti1=itortyp(itype(i+1))
3309         iti2=itortyp(itype(i+2))
3310         iti3=itortyp(itype(i+3))
3311         call transpose2(EUg(1,1,i+1),e1t(1,1))
3312         call transpose2(Eug(1,1,i+2),e2t(1,1))
3313         call transpose2(Eug(1,1,i+3),e3t(1,1))
3314         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3315         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3316         s1=scalar2(b1(1,iti2),auxvec(1))
3317         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3318         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3319         s2=scalar2(b1(1,iti1),auxvec(1))
3320         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3321         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3322         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3323         if (shield_mode.eq.0) then
3324         fac_shield(i)=1.0
3325         fac_shield(j)=1.0
3326 C        else
3327 C        fac_shield(i)=0.4
3328 C        fac_shield(j)=0.6
3329         endif
3330         eello_turn4=eello_turn4-(s1+s2+s3)
3331      &  *fac_shield(i)*fac_shield(j)
3332         eello_t4=-(s1+s2+s3)
3333      &  *fac_shield(i)*fac_shield(j)
3334
3335 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3336 cd     &    ' eello_turn4_num',8*eello_turn4_num
3337 C Derivatives in gamma(i)
3338         if (calc_grad) then
3339           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3340      &  (shield_mode.gt.0)) then
3341 C          print *,i,j
3342
3343           do ilist=1,ishield_list(i)
3344            iresshield=shield_list(ilist,i)
3345            do k=1,3
3346            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3347 C     &      *2.0
3348            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3349      &              rlocshield
3350      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3351             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3352      &      +rlocshield
3353            enddo
3354           enddo
3355           do ilist=1,ishield_list(j)
3356            iresshield=shield_list(ilist,j)
3357            do k=1,3
3358            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3359 C     &     *2.0
3360            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3361      &              rlocshield
3362      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3363            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3364      &             +rlocshield
3365
3366            enddo
3367           enddo
3368
3369           do k=1,3
3370             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3371      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3372             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3373      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3374             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3375      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3376             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3377      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3378            enddo
3379            endif
3380
3381         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3382         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3383         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3384         s1=scalar2(b1(1,iti2),auxvec(1))
3385         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3386         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3387         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3388      &  *fac_shield(i)*fac_shield(j)
3389
3390 C Derivatives in gamma(i+1)
3391         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3392         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3393         s2=scalar2(b1(1,iti1),auxvec(1))
3394         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3395         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3396         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3397         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3398      &  *fac_shield(i)*fac_shield(j)
3399
3400 C Derivatives in gamma(i+2)
3401         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3402         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3403         s1=scalar2(b1(1,iti2),auxvec(1))
3404         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3405         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3406         s2=scalar2(b1(1,iti1),auxvec(1))
3407         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3408         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3409         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3410         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3411      &  *fac_shield(i)*fac_shield(j)
3412
3413 C Cartesian derivatives
3414 C Derivatives of this turn contributions in DC(i+2)
3415         if (j.lt.nres-1) then
3416           do l=1,3
3417             a_temp(1,1)=agg(l,1)
3418             a_temp(1,2)=agg(l,2)
3419             a_temp(2,1)=agg(l,3)
3420             a_temp(2,2)=agg(l,4)
3421             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3422             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3423             s1=scalar2(b1(1,iti2),auxvec(1))
3424             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3425             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3426             s2=scalar2(b1(1,iti1),auxvec(1))
3427             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3428             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3429             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3430             ggg(l)=-(s1+s2+s3)
3431             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3432      &  *fac_shield(i)*fac_shield(j)
3433
3434           enddo
3435         endif
3436 C Remaining derivatives of this turn contribution
3437         do l=1,3
3438           a_temp(1,1)=aggi(l,1)
3439           a_temp(1,2)=aggi(l,2)
3440           a_temp(2,1)=aggi(l,3)
3441           a_temp(2,2)=aggi(l,4)
3442           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3443           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3444           s1=scalar2(b1(1,iti2),auxvec(1))
3445           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3446           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3447           s2=scalar2(b1(1,iti1),auxvec(1))
3448           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3449           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3450           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3451           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3452      &  *fac_shield(i)*fac_shield(j)
3453
3454           a_temp(1,1)=aggi1(l,1)
3455           a_temp(1,2)=aggi1(l,2)
3456           a_temp(2,1)=aggi1(l,3)
3457           a_temp(2,2)=aggi1(l,4)
3458           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3459           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3460           s1=scalar2(b1(1,iti2),auxvec(1))
3461           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3462           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3463           s2=scalar2(b1(1,iti1),auxvec(1))
3464           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3465           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3466           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3467           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3468      &  *fac_shield(i)*fac_shield(j)
3469
3470           a_temp(1,1)=aggj(l,1)
3471           a_temp(1,2)=aggj(l,2)
3472           a_temp(2,1)=aggj(l,3)
3473           a_temp(2,2)=aggj(l,4)
3474           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3475           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3476           s1=scalar2(b1(1,iti2),auxvec(1))
3477           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3478           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3479           s2=scalar2(b1(1,iti1),auxvec(1))
3480           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3481           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3482           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3483           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3484      &  *fac_shield(i)*fac_shield(j)
3485
3486           a_temp(1,1)=aggj1(l,1)
3487           a_temp(1,2)=aggj1(l,2)
3488           a_temp(2,1)=aggj1(l,3)
3489           a_temp(2,2)=aggj1(l,4)
3490           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3491           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3492           s1=scalar2(b1(1,iti2),auxvec(1))
3493           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3494           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3495           s2=scalar2(b1(1,iti1),auxvec(1))
3496           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3497           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3498           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3499           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3500      &  *fac_shield(i)*fac_shield(j)
3501
3502         enddo
3503         endif
3504   178 continue
3505       endif
3506       return
3507       end
3508 C-----------------------------------------------------------------------------
3509       subroutine vecpr(u,v,w)
3510       implicit real*8(a-h,o-z)
3511       dimension u(3),v(3),w(3)
3512       w(1)=u(2)*v(3)-u(3)*v(2)
3513       w(2)=-u(1)*v(3)+u(3)*v(1)
3514       w(3)=u(1)*v(2)-u(2)*v(1)
3515       return
3516       end
3517 C-----------------------------------------------------------------------------
3518       subroutine unormderiv(u,ugrad,unorm,ungrad)
3519 C This subroutine computes the derivatives of a normalized vector u, given
3520 C the derivatives computed without normalization conditions, ugrad. Returns
3521 C ungrad.
3522       implicit none
3523       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3524       double precision vec(3)
3525       double precision scalar
3526       integer i,j
3527 c      write (2,*) 'ugrad',ugrad
3528 c      write (2,*) 'u',u
3529       do i=1,3
3530         vec(i)=scalar(ugrad(1,i),u(1))
3531       enddo
3532 c      write (2,*) 'vec',vec
3533       do i=1,3
3534         do j=1,3
3535           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3536         enddo
3537       enddo
3538 c      write (2,*) 'ungrad',ungrad
3539       return
3540       end
3541 C-----------------------------------------------------------------------------
3542       subroutine escp(evdw2,evdw2_14)
3543 C
3544 C This subroutine calculates the excluded-volume interaction energy between
3545 C peptide-group centers and side chains and its gradient in virtual-bond and
3546 C side-chain vectors.
3547 C
3548       implicit real*8 (a-h,o-z)
3549       include 'DIMENSIONS'
3550       include 'sizesclu.dat'
3551       include 'COMMON.GEO'
3552       include 'COMMON.VAR'
3553       include 'COMMON.LOCAL'
3554       include 'COMMON.CHAIN'
3555       include 'COMMON.DERIV'
3556       include 'COMMON.INTERACT'
3557       include 'COMMON.FFIELD'
3558       include 'COMMON.IOUNITS'
3559       integer xshift,yshift,zshift
3560       dimension ggg(3)
3561       evdw2=0.0D0
3562       evdw2_14=0.0d0
3563 cd    print '(a)','Enter ESCP'
3564 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3565 c     &  ' scal14',scal14
3566       do i=iatscp_s,iatscp_e
3567         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3568         iteli=itel(i)
3569 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3570 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3571         if (iteli.eq.0) goto 1225
3572         xi=0.5D0*(c(1,i)+c(1,i+1))
3573         yi=0.5D0*(c(2,i)+c(2,i+1))
3574         zi=0.5D0*(c(3,i)+c(3,i+1))
3575 C    Returning the ith atom to box
3576           xi=mod(xi,boxxsize)
3577           if (xi.lt.0) xi=xi+boxxsize
3578           yi=mod(yi,boxysize)
3579           if (yi.lt.0) yi=yi+boxysize
3580           zi=mod(zi,boxzsize)
3581           if (zi.lt.0) zi=zi+boxzsize
3582
3583         do iint=1,nscp_gr(i)
3584
3585         do j=iscpstart(i,iint),iscpend(i,iint)
3586           itypj=iabs(itype(j))
3587           if (itypj.eq.ntyp1) cycle
3588 C Uncomment following three lines for SC-p interactions
3589 c         xj=c(1,nres+j)-xi
3590 c         yj=c(2,nres+j)-yi
3591 c         zj=c(3,nres+j)-zi
3592 C Uncomment following three lines for Ca-p interactions
3593           xj=c(1,j)
3594           yj=c(2,j)
3595           zj=c(3,j)
3596 C returning the jth atom to box
3597           xj=mod(xj,boxxsize)
3598           if (xj.lt.0) xj=xj+boxxsize
3599           yj=mod(yj,boxysize)
3600           if (yj.lt.0) yj=yj+boxysize
3601           zj=mod(zj,boxzsize)
3602           if (zj.lt.0) zj=zj+boxzsize
3603       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3604       xj_safe=xj
3605       yj_safe=yj
3606       zj_safe=zj
3607       subchap=0
3608 C Finding the closest jth atom
3609       do xshift=-1,1
3610       do yshift=-1,1
3611       do zshift=-1,1
3612           xj=xj_safe+xshift*boxxsize
3613           yj=yj_safe+yshift*boxysize
3614           zj=zj_safe+zshift*boxzsize
3615           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3616           if(dist_temp.lt.dist_init) then
3617             dist_init=dist_temp
3618             xj_temp=xj
3619             yj_temp=yj
3620             zj_temp=zj
3621             subchap=1
3622           endif
3623        enddo
3624        enddo
3625        enddo
3626        if (subchap.eq.1) then
3627           xj=xj_temp-xi
3628           yj=yj_temp-yi
3629           zj=zj_temp-zi
3630        else
3631           xj=xj_safe-xi
3632           yj=yj_safe-yi
3633           zj=zj_safe-zi
3634        endif
3635
3636           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3637 C sss is scaling function for smoothing the cutoff gradient otherwise
3638 C the gradient would not be continuouse
3639           sss=sscale(1.0d0/(dsqrt(rrij)))
3640           if (sss.le.0.0d0) cycle
3641           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3642           fac=rrij**expon2
3643           e1=fac*fac*aad(itypj,iteli)
3644           e2=fac*bad(itypj,iteli)
3645           if (iabs(j-i) .le. 2) then
3646             e1=scal14*e1
3647             e2=scal14*e2
3648             evdw2_14=evdw2_14+(e1+e2)*sss
3649           endif
3650           evdwij=e1+e2
3651 c          write (iout,*) i,j,evdwij
3652           evdw2=evdw2+evdwij*sss
3653           if (calc_grad) then
3654 C
3655 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3656 C
3657            fac=-(evdwij+e1)*rrij*sss
3658            fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3659           ggg(1)=xj*fac
3660           ggg(2)=yj*fac
3661           ggg(3)=zj*fac
3662           if (j.lt.i) then
3663 cd          write (iout,*) 'j<i'
3664 C Uncomment following three lines for SC-p interactions
3665 c           do k=1,3
3666 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3667 c           enddo
3668           else
3669 cd          write (iout,*) 'j>i'
3670             do k=1,3
3671               ggg(k)=-ggg(k)
3672 C Uncomment following line for SC-p interactions
3673 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3674             enddo
3675           endif
3676           do k=1,3
3677             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3678           enddo
3679           kstart=min0(i+1,j)
3680           kend=max0(i-1,j-1)
3681 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3682 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3683           do k=kstart,kend
3684             do l=1,3
3685               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3686             enddo
3687           enddo
3688           endif
3689         enddo
3690         enddo ! iint
3691  1225   continue
3692       enddo ! i
3693       do i=1,nct
3694         do j=1,3
3695           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3696           gradx_scp(j,i)=expon*gradx_scp(j,i)
3697         enddo
3698       enddo
3699 C******************************************************************************
3700 C
3701 C                              N O T E !!!
3702 C
3703 C To save time the factor EXPON has been extracted from ALL components
3704 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3705 C use!
3706 C
3707 C******************************************************************************
3708       return
3709       end
3710 C--------------------------------------------------------------------------
3711       subroutine edis(ehpb)
3712 C
3713 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3714 C
3715       implicit real*8 (a-h,o-z)
3716       include 'DIMENSIONS'
3717       include 'sizesclu.dat'
3718       include 'COMMON.SBRIDGE'
3719       include 'COMMON.CHAIN'
3720       include 'COMMON.DERIV'
3721       include 'COMMON.VAR'
3722       include 'COMMON.INTERACT'
3723       include 'COMMON.CONTROL'
3724       dimension ggg(3)
3725       ehpb=0.0D0
3726 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3727 cd    print *,'link_start=',link_start,' link_end=',link_end
3728       if (link_end.eq.0) return
3729       do i=link_start,link_end
3730 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3731 C CA-CA distance used in regularization of structure.
3732         ii=ihpb(i)
3733         jj=jhpb(i)
3734 C iii and jjj point to the residues for which the distance is assigned.
3735         if (ii.gt.nres) then
3736           iii=ii-nres
3737           jjj=jj-nres
3738         else
3739           iii=ii
3740           jjj=jj
3741         endif
3742 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3743 C    distance and angle dependent SS bond potential.
3744 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3745 C     &  iabs(itype(jjj)).eq.1) then
3746 C          call ssbond_ene(iii,jjj,eij)
3747 C          ehpb=ehpb+2*eij
3748 C        else
3749        if (.not.dyn_ss .and. i.le.nss) then
3750          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3751      & iabs(itype(jjj)).eq.1) then
3752           call ssbond_ene(iii,jjj,eij)
3753           ehpb=ehpb+2*eij
3754            endif !ii.gt.neres
3755         else if (ii.gt.nres .and. jj.gt.nres) then
3756 c Restraints from contact prediction
3757           dd=dist(ii,jj)
3758           if (constr_dist.eq.11) then
3759 C            ehpb=ehpb+fordepth(i)**4.0d0
3760 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3761             ehpb=ehpb+fordepth(i)**4.0d0
3762      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3763             fac=fordepth(i)**4.0d0
3764      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3765 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3766 C     &    ehpb,fordepth(i),dd
3767 C             print *,"TUTU"
3768 C            write(iout,*) ehpb,"atu?"
3769 C            ehpb,"tu?"
3770 C            fac=fordepth(i)**4.0d0
3771 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3772            else !constr_dist.eq.11
3773           if (dhpb1(i).gt.0.0d0) then
3774             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3775             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3776 c            write (iout,*) "beta nmr",
3777 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3778           else !dhpb(i).gt.0.00
3779
3780 C Calculate the distance between the two points and its difference from the
3781 C target distance.
3782         dd=dist(ii,jj)
3783         rdis=dd-dhpb(i)
3784 C Get the force constant corresponding to this distance.
3785         waga=forcon(i)
3786 C Calculate the contribution to energy.
3787         ehpb=ehpb+waga*rdis*rdis
3788 C
3789 C Evaluate gradient.
3790 C
3791         fac=waga*rdis/dd
3792         endif !dhpb(i).gt.0
3793         endif
3794 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3795 cd   &   ' waga=',waga,' fac=',fac
3796         do j=1,3
3797           ggg(j)=fac*(c(j,jj)-c(j,ii))
3798         enddo
3799 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3800 C If this is a SC-SC distance, we need to calculate the contributions to the
3801 C Cartesian gradient in the SC vectors (ghpbx).
3802         if (iii.lt.ii) then
3803           do j=1,3
3804             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3805             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3806           enddo
3807         endif
3808         else !ii.gt.nres
3809 C          write(iout,*) "before"
3810           dd=dist(ii,jj)
3811 C          write(iout,*) "after",dd
3812           if (constr_dist.eq.11) then
3813             ehpb=ehpb+fordepth(i)**4.0d0
3814      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3815             fac=fordepth(i)**4.0d0
3816      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3817 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3818 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3819 C            print *,ehpb,"tu?"
3820 C            write(iout,*) ehpb,"btu?",
3821 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3822 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3823 C     &    ehpb,fordepth(i),dd
3824            else
3825           if (dhpb1(i).gt.0.0d0) then
3826             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3827             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3828 c            write (iout,*) "alph nmr",
3829 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3830           else
3831             rdis=dd-dhpb(i)
3832 C Get the force constant corresponding to this distance.
3833             waga=forcon(i)
3834 C Calculate the contribution to energy.
3835             ehpb=ehpb+waga*rdis*rdis
3836 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3837 C
3838 C Evaluate gradient.
3839 C
3840             fac=waga*rdis/dd
3841           endif
3842           endif
3843         do j=1,3
3844           ggg(j)=fac*(c(j,jj)-c(j,ii))
3845         enddo
3846 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3847 C If this is a SC-SC distance, we need to calculate the contributions to the
3848 C Cartesian gradient in the SC vectors (ghpbx).
3849         if (iii.lt.ii) then
3850           do j=1,3
3851             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3852             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3853           enddo
3854         endif
3855         do j=iii,jjj-1
3856           do k=1,3
3857             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3858           enddo
3859         enddo
3860         endif
3861       enddo
3862       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3863       return
3864       end
3865 C--------------------------------------------------------------------------
3866       subroutine ssbond_ene(i,j,eij)
3867 C
3868 C Calculate the distance and angle dependent SS-bond potential energy
3869 C using a free-energy function derived based on RHF/6-31G** ab initio
3870 C calculations of diethyl disulfide.
3871 C
3872 C A. Liwo and U. Kozlowska, 11/24/03
3873 C
3874       implicit real*8 (a-h,o-z)
3875       include 'DIMENSIONS'
3876       include 'sizesclu.dat'
3877       include 'COMMON.SBRIDGE'
3878       include 'COMMON.CHAIN'
3879       include 'COMMON.DERIV'
3880       include 'COMMON.LOCAL'
3881       include 'COMMON.INTERACT'
3882       include 'COMMON.VAR'
3883       include 'COMMON.IOUNITS'
3884       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3885       itypi=iabs(itype(i))
3886       xi=c(1,nres+i)
3887       yi=c(2,nres+i)
3888       zi=c(3,nres+i)
3889       dxi=dc_norm(1,nres+i)
3890       dyi=dc_norm(2,nres+i)
3891       dzi=dc_norm(3,nres+i)
3892       dsci_inv=dsc_inv(itypi)
3893       itypj=iabs(itype(j))
3894       dscj_inv=dsc_inv(itypj)
3895       xj=c(1,nres+j)-xi
3896       yj=c(2,nres+j)-yi
3897       zj=c(3,nres+j)-zi
3898       dxj=dc_norm(1,nres+j)
3899       dyj=dc_norm(2,nres+j)
3900       dzj=dc_norm(3,nres+j)
3901       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3902       rij=dsqrt(rrij)
3903       erij(1)=xj*rij
3904       erij(2)=yj*rij
3905       erij(3)=zj*rij
3906       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3907       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3908       om12=dxi*dxj+dyi*dyj+dzi*dzj
3909       do k=1,3
3910         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3911         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3912       enddo
3913       rij=1.0d0/rij
3914       deltad=rij-d0cm
3915       deltat1=1.0d0-om1
3916       deltat2=1.0d0+om2
3917       deltat12=om2-om1+2.0d0
3918       cosphi=om12-om1*om2
3919       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3920      &  +akct*deltad*deltat12
3921      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3922 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3923 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3924 c     &  " deltat12",deltat12," eij",eij
3925       ed=2*akcm*deltad+akct*deltat12
3926       pom1=akct*deltad
3927       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3928       eom1=-2*akth*deltat1-pom1-om2*pom2
3929       eom2= 2*akth*deltat2+pom1-om1*pom2
3930       eom12=pom2
3931       do k=1,3
3932         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3933       enddo
3934       do k=1,3
3935         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3936      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3937         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3938      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3939       enddo
3940 C
3941 C Calculate the components of the gradient in DC and X
3942 C
3943       do k=i,j-1
3944         do l=1,3
3945           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3946         enddo
3947       enddo
3948       return
3949       end
3950 C--------------------------------------------------------------------------
3951
3952
3953 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
3954       subroutine e_modeller(ehomology_constr)
3955       implicit real*8 (a-h,o-z)
3956
3957       include 'DIMENSIONS'
3958
3959       integer nnn, i, j, k, ki, irec, l
3960       integer katy, odleglosci, test7
3961       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3962       real*8 distance(max_template),distancek(max_template),
3963      &    min_odl,godl(max_template),dih_diff(max_template)
3964
3965 c
3966 c     FP - 30/10/2014 Temporary specifications for homology restraints
3967 c
3968       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3969      &                 sgtheta
3970       double precision, dimension (maxres) :: guscdiff,usc_diff
3971       double precision, dimension (max_template) ::
3972      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3973      &           theta_diff
3974
3975       include 'COMMON.SBRIDGE'
3976       include 'COMMON.CHAIN'
3977       include 'COMMON.GEO'
3978       include 'COMMON.DERIV'
3979       include 'COMMON.LOCAL'
3980       include 'COMMON.INTERACT'
3981       include 'COMMON.VAR'
3982       include 'COMMON.IOUNITS'
3983       include 'COMMON.CONTROL'
3984       include 'COMMON.HOMRESTR'
3985 c
3986       include 'COMMON.SETUP'
3987       include 'COMMON.NAMES'
3988
3989       do i=1,max_template
3990         distancek(i)=9999999.9
3991       enddo
3992
3993       odleg=0.0d0
3994
3995 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3996 c function)
3997 C AL 5/2/14 - Introduce list of restraints
3998 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3999 #ifdef DEBUG
4000       write(iout,*) "------- dist restrs start -------"
4001       write (iout,*) "link_start_homo",link_start_homo,
4002      &    " link_end_homo",link_end_homo
4003 #endif
4004       do ii = link_start_homo,link_end_homo
4005          i = ires_homo(ii)
4006          j = jres_homo(ii)
4007          dij=dist(i,j)
4008 c        write (iout,*) "dij(",i,j,") =",dij
4009          do k=1,constr_homology
4010            if(.not.l_homo(k,ii)) cycle
4011            distance(k)=odl(k,ii)-dij
4012 c          write (iout,*) "distance(",k,") =",distance(k)
4013 c
4014 c          For Gaussian-type Urestr
4015 c
4016            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4017 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4018 c          write (iout,*) "distancek(",k,") =",distancek(k)
4019 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4020 c
4021 c          For Lorentzian-type Urestr
4022 c
4023            if (waga_dist.lt.0.0d0) then
4024               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4025               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4026      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4027            endif
4028          enddo
4029
4030 c         min_odl=minval(distancek)
4031          do kk=1,constr_homology
4032           if(l_homo(kk,ii)) then
4033             min_odl=distancek(kk)
4034             exit
4035           endif
4036          enddo
4037          do kk=1,constr_homology
4038           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4039      &              min_odl=distancek(kk)
4040          enddo
4041 c        write (iout,* )"min_odl",min_odl
4042 #ifdef DEBUG
4043          write (iout,*) "ij dij",i,j,dij
4044          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4045          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4046          write (iout,* )"min_odl",min_odl
4047 #endif
4048          odleg2=0.0d0
4049          do k=1,constr_homology
4050 c Nie wiem po co to liczycie jeszcze raz!
4051 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4052 c     &              (2*(sigma_odl(i,j,k))**2))
4053            if(.not.l_homo(k,ii)) cycle
4054            if (waga_dist.ge.0.0d0) then
4055 c
4056 c          For Gaussian-type Urestr
4057 c
4058             godl(k)=dexp(-distancek(k)+min_odl)
4059             odleg2=odleg2+godl(k)
4060 c
4061 c          For Lorentzian-type Urestr
4062 c
4063            else
4064             odleg2=odleg2+distancek(k)
4065            endif
4066
4067 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4068 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4069 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4070 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4071
4072          enddo
4073 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4074 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4075 #ifdef DEBUG
4076          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4077          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4078 #endif
4079            if (waga_dist.ge.0.0d0) then
4080 c
4081 c          For Gaussian-type Urestr
4082 c
4083               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4084 c
4085 c          For Lorentzian-type Urestr
4086 c
4087            else
4088               odleg=odleg+odleg2/constr_homology
4089            endif
4090 c
4091 #ifdef GRAD
4092 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4093 c Gradient
4094 c
4095 c          For Gaussian-type Urestr
4096 c
4097          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4098          sum_sgodl=0.0d0
4099          do k=1,constr_homology
4100 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4101 c     &           *waga_dist)+min_odl
4102 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4103 c
4104          if(.not.l_homo(k,ii)) cycle
4105          if (waga_dist.ge.0.0d0) then
4106 c          For Gaussian-type Urestr
4107 c
4108            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4109 c
4110 c          For Lorentzian-type Urestr
4111 c
4112          else
4113            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4114      &           sigma_odlir(k,ii)**2)**2)
4115          endif
4116            sum_sgodl=sum_sgodl+sgodl
4117
4118 c            sgodl2=sgodl2+sgodl
4119 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4120 c      write(iout,*) "constr_homology=",constr_homology
4121 c      write(iout,*) i, j, k, "TEST K"
4122          enddo
4123          if (waga_dist.ge.0.0d0) then
4124 c
4125 c          For Gaussian-type Urestr
4126 c
4127             grad_odl3=waga_homology(iset)*waga_dist
4128      &                *sum_sgodl/(sum_godl*dij)
4129 c
4130 c          For Lorentzian-type Urestr
4131 c
4132          else
4133 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4134 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4135             grad_odl3=-waga_homology(iset)*waga_dist*
4136      &                sum_sgodl/(constr_homology*dij)
4137          endif
4138 c
4139 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4140
4141
4142 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4143 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4144 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4145
4146 ccc      write(iout,*) godl, sgodl, grad_odl3
4147
4148 c          grad_odl=grad_odl+grad_odl3
4149
4150          do jik=1,3
4151             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4152 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4153 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4154 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4155             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4156             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4157 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4158 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4159 c         if (i.eq.25.and.j.eq.27) then
4160 c         write(iout,*) "jik",jik,"i",i,"j",j
4161 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4162 c         write(iout,*) "grad_odl3",grad_odl3
4163 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4164 c         write(iout,*) "ggodl",ggodl
4165 c         write(iout,*) "ghpbc(",jik,i,")",
4166 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4167 c     &                 ghpbc(jik,j)
4168 c         endif
4169          enddo
4170 #endif
4171 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4172 ccc     & dLOG(odleg2),"-odleg=", -odleg
4173
4174       enddo ! ii-loop for dist
4175 #ifdef DEBUG
4176       write(iout,*) "------- dist restrs end -------"
4177 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4178 c    &     waga_d.eq.1.0d0) call sum_gradient
4179 #endif
4180 c Pseudo-energy and gradient from dihedral-angle restraints from
4181 c homology templates
4182 c      write (iout,*) "End of distance loop"
4183 c      call flush(iout)
4184       kat=0.0d0
4185 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4186 #ifdef DEBUG
4187       write(iout,*) "------- dih restrs start -------"
4188       do i=idihconstr_start_homo,idihconstr_end_homo
4189         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4190       enddo
4191 #endif
4192       do i=idihconstr_start_homo,idihconstr_end_homo
4193         kat2=0.0d0
4194 c        betai=beta(i,i+1,i+2,i+3)
4195         betai = phi(i)
4196 c       write (iout,*) "betai =",betai
4197         do k=1,constr_homology
4198           dih_diff(k)=pinorm(dih(k,i)-betai)
4199 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4200 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4201 c     &                                   -(6.28318-dih_diff(i,k))
4202 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4203 c     &                                   6.28318+dih_diff(i,k)
4204
4205           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4206 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4207           gdih(k)=dexp(kat3)
4208           kat2=kat2+gdih(k)
4209 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4210 c          write(*,*)""
4211         enddo
4212 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4213 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4214 #ifdef DEBUG
4215         write (iout,*) "i",i," betai",betai," kat2",kat2
4216         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4217 #endif
4218         if (kat2.le.1.0d-14) cycle
4219         kat=kat-dLOG(kat2/constr_homology)
4220 c       write (iout,*) "kat",kat ! sum of -ln-s
4221
4222 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4223 ccc     & dLOG(kat2), "-kat=", -kat
4224
4225 #ifdef GRAD
4226 c ----------------------------------------------------------------------
4227 c Gradient
4228 c ----------------------------------------------------------------------
4229
4230         sum_gdih=kat2
4231         sum_sgdih=0.0d0
4232         do k=1,constr_homology
4233           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4234 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4235           sum_sgdih=sum_sgdih+sgdih
4236         enddo
4237 c       grad_dih3=sum_sgdih/sum_gdih
4238         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4239
4240 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4241 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4242 ccc     & gloc(nphi+i-3,icg)
4243         gloc(i,icg)=gloc(i,icg)+grad_dih3
4244 c        if (i.eq.25) then
4245 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4246 c        endif
4247 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4248 ccc     & gloc(nphi+i-3,icg)
4249 #endif
4250       enddo ! i-loop for dih
4251 #ifdef DEBUG
4252       write(iout,*) "------- dih restrs end -------"
4253 #endif
4254
4255 c Pseudo-energy and gradient for theta angle restraints from
4256 c homology templates
4257 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4258 c adapted
4259
4260 c
4261 c     For constr_homology reference structures (FP)
4262 c
4263 c     Uconst_back_tot=0.0d0
4264       Eval=0.0d0
4265       Erot=0.0d0
4266 c     Econstr_back legacy
4267 #ifdef GRAD
4268       do i=1,nres
4269 c     do i=ithet_start,ithet_end
4270        dutheta(i)=0.0d0
4271 c     enddo
4272 c     do i=loc_start,loc_end
4273         do j=1,3
4274           duscdiff(j,i)=0.0d0
4275           duscdiffx(j,i)=0.0d0
4276         enddo
4277       enddo
4278 #endif
4279 c
4280 c     do iref=1,nref
4281 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4282 c     write (iout,*) "waga_theta",waga_theta
4283       if (waga_theta.gt.0.0d0) then
4284 #ifdef DEBUG
4285       write (iout,*) "usampl",usampl
4286       write(iout,*) "------- theta restrs start -------"
4287 c     do i=ithet_start,ithet_end
4288 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4289 c     enddo
4290 #endif
4291 c     write (iout,*) "maxres",maxres,"nres",nres
4292
4293       do i=ithet_start,ithet_end
4294 c
4295 c     do i=1,nfrag_back
4296 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4297 c
4298 c Deviation of theta angles wrt constr_homology ref structures
4299 c
4300         utheta_i=0.0d0 ! argument of Gaussian for single k
4301         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4302 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4303 c       over residues in a fragment
4304 c       write (iout,*) "theta(",i,")=",theta(i)
4305         do k=1,constr_homology
4306 c
4307 c         dtheta_i=theta(j)-thetaref(j,iref)
4308 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4309           theta_diff(k)=thetatpl(k,i)-theta(i)
4310 c
4311           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4312 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4313           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4314           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4315 c         Gradient for single Gaussian restraint in subr Econstr_back
4316 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4317 c
4318         enddo
4319 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4320 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4321
4322 c
4323 #ifdef GRAD
4324 c         Gradient for multiple Gaussian restraint
4325         sum_gtheta=gutheta_i
4326         sum_sgtheta=0.0d0
4327         do k=1,constr_homology
4328 c        New generalized expr for multiple Gaussian from Econstr_back
4329          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4330 c
4331 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4332           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4333         enddo
4334 c
4335 c       Final value of gradient using same var as in Econstr_back
4336         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4337      &               *waga_homology(iset)
4338 c       dutheta(i)=sum_sgtheta/sum_gtheta
4339 c
4340 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4341 #endif
4342         Eval=Eval-dLOG(gutheta_i/constr_homology)
4343 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4344 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4345 c       Uconst_back=Uconst_back+utheta(i)
4346       enddo ! (i-loop for theta)
4347 #ifdef DEBUG
4348       write(iout,*) "------- theta restrs end -------"
4349 #endif
4350       endif
4351 c
4352 c Deviation of local SC geometry
4353 c
4354 c Separation of two i-loops (instructed by AL - 11/3/2014)
4355 c
4356 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4357 c     write (iout,*) "waga_d",waga_d
4358
4359 #ifdef DEBUG
4360       write(iout,*) "------- SC restrs start -------"
4361       write (iout,*) "Initial duscdiff,duscdiffx"
4362       do i=loc_start,loc_end
4363         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4364      &                 (duscdiffx(jik,i),jik=1,3)
4365       enddo
4366 #endif
4367       do i=loc_start,loc_end
4368         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4369         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4370 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4371 c       write(iout,*) "xxtab, yytab, zztab"
4372 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4373         do k=1,constr_homology
4374 c
4375           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4376 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4377           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4378           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4379 c         write(iout,*) "dxx, dyy, dzz"
4380 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4381 c
4382           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4383 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4384 c         uscdiffk(k)=usc_diff(i)
4385           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4386           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4387 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4388 c     &      xxref(j),yyref(j),zzref(j)
4389         enddo
4390 c
4391 c       Gradient
4392 c
4393 c       Generalized expression for multiple Gaussian acc to that for a single
4394 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4395 c
4396 c       Original implementation
4397 c       sum_guscdiff=guscdiff(i)
4398 c
4399 c       sum_sguscdiff=0.0d0
4400 c       do k=1,constr_homology
4401 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4402 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4403 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
4404 c       enddo
4405 c
4406 c       Implementation of new expressions for gradient (Jan. 2015)
4407 c
4408 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
4409 #ifdef GRAD
4410         do k=1,constr_homology
4411 c
4412 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
4413 c       before. Now the drivatives should be correct
4414 c
4415           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4416 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
4417           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4418           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4419 c
4420 c         New implementation
4421 c
4422           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
4423      &                 sigma_d(k,i) ! for the grad wrt r'
4424 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
4425 c
4426 c
4427 c        New implementation
4428          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
4429          do jik=1,3
4430             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
4431      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
4432      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
4433             duscdiff(jik,i)=duscdiff(jik,i)+
4434      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
4435      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
4436             duscdiffx(jik,i)=duscdiffx(jik,i)+
4437      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
4438      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
4439 c
4440 #ifdef DEBUG
4441              write(iout,*) "jik",jik,"i",i
4442              write(iout,*) "dxx, dyy, dzz"
4443              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4444              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
4445 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
4446 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
4447 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
4448 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
4449 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
4450 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
4451 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
4452 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
4453 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
4454 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
4455 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
4456 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
4457 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
4458 c            endif
4459 #endif
4460          enddo
4461         enddo
4462 #endif
4463 c
4464 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
4465 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
4466 c
4467 c        write (iout,*) i," uscdiff",uscdiff(i)
4468 c
4469 c Put together deviations from local geometry
4470
4471 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
4472 c      &            wfrag_back(3,i,iset)*uscdiff(i)
4473         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
4474 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
4475 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
4476 c       Uconst_back=Uconst_back+usc_diff(i)
4477 c
4478 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
4479 c
4480 c     New implment: multiplied by sum_sguscdiff
4481 c
4482
4483       enddo ! (i-loop for dscdiff)
4484
4485 c      endif
4486
4487 #ifdef DEBUG
4488       write(iout,*) "------- SC restrs end -------"
4489         write (iout,*) "------ After SC loop in e_modeller ------"
4490         do i=loc_start,loc_end
4491          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
4492          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
4493         enddo
4494       if (waga_theta.eq.1.0d0) then
4495       write (iout,*) "in e_modeller after SC restr end: dutheta"
4496       do i=ithet_start,ithet_end
4497         write (iout,*) i,dutheta(i)
4498       enddo
4499       endif
4500       if (waga_d.eq.1.0d0) then
4501       write (iout,*) "e_modeller after SC loop: duscdiff/x"
4502       do i=1,nres
4503         write (iout,*) i,(duscdiff(j,i),j=1,3)
4504         write (iout,*) i,(duscdiffx(j,i),j=1,3)
4505       enddo
4506       endif
4507 #endif
4508
4509 c Total energy from homology restraints
4510 #ifdef DEBUG
4511       write (iout,*) "odleg",odleg," kat",kat
4512       write (iout,*) "odleg",odleg," kat",kat
4513       write (iout,*) "Eval",Eval," Erot",Erot
4514       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4515       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
4516       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
4517       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4518 #endif
4519 c
4520 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
4521 c
4522 c     ehomology_constr=odleg+kat
4523 c
4524 c     For Lorentzian-type Urestr
4525 c
4526
4527       if (waga_dist.ge.0.0d0) then
4528 c
4529 c          For Gaussian-type Urestr
4530 c
4531         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4532      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4533 c     write (iout,*) "ehomology_constr=",ehomology_constr
4534       else
4535 c
4536 c          For Lorentzian-type Urestr
4537 c
4538         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4539      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4540 c     write (iout,*) "ehomology_constr=",ehomology_constr
4541       endif
4542 #ifdef DEBUG
4543       write (iout,*) "iset",iset," waga_homology",waga_homology(iset)
4544       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4545      & " Eval",waga_theta,Eval," Erot",waga_d,Erot
4546       write (iout,*) "ehomology_constr",ehomology_constr
4547 #endif
4548       return
4549
4550   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4551   747 format(a12,i4,i4,i4,f8.3,f8.3)
4552   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4553   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4554   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4555      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4556       end
4557 C--------------------------------------------------------------------------
4558
4559 C--------------------------------------------------------------------------
4560       subroutine ebond(estr)
4561 c
4562 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4563 c
4564       implicit real*8 (a-h,o-z)
4565       include 'DIMENSIONS'
4566       include 'sizesclu.dat'
4567       include 'COMMON.LOCAL'
4568       include 'COMMON.GEO'
4569       include 'COMMON.INTERACT'
4570       include 'COMMON.DERIV'
4571       include 'COMMON.VAR'
4572       include 'COMMON.CHAIN'
4573       include 'COMMON.IOUNITS'
4574       include 'COMMON.NAMES'
4575       include 'COMMON.FFIELD'
4576       include 'COMMON.CONTROL'
4577       logical energy_dec /.false./
4578       double precision u(3),ud(3)
4579       estr=0.0d0
4580       estr1=0.0d0
4581       do i=nnt+1,nct
4582         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4583 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4584 C          do j=1,3
4585 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4586 C     &      *dc(j,i-1)/vbld(i)
4587 C          enddo
4588 C          if (energy_dec) write(iout,*)
4589 C     &       "estr1",i,vbld(i),distchainmax,
4590 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4591 C        else
4592          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4593         diff = vbld(i)-vbldpDUM
4594          else
4595           diff = vbld(i)-vbldp0
4596 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4597          endif
4598           estr=estr+diff*diff
4599           do j=1,3
4600             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4601           enddo
4602 C        endif
4603 C        write (iout,'(a7,i5,4f7.3)')
4604 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4605       enddo
4606       estr=0.5d0*AKP*estr+estr1
4607 c
4608 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4609 c
4610       do i=nnt,nct
4611         iti=iabs(itype(i))
4612         if (iti.ne.10 .and. iti.ne.ntyp1) then
4613           nbi=nbondterm(iti)
4614           if (nbi.eq.1) then
4615             diff=vbld(i+nres)-vbldsc0(1,iti)
4616 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4617 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4618             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4619             do j=1,3
4620               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4621             enddo
4622           else
4623             do j=1,nbi
4624               diff=vbld(i+nres)-vbldsc0(j,iti)
4625               ud(j)=aksc(j,iti)*diff
4626               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4627             enddo
4628             uprod=u(1)
4629             do j=2,nbi
4630               uprod=uprod*u(j)
4631             enddo
4632             usum=0.0d0
4633             usumsqder=0.0d0
4634             do j=1,nbi
4635               uprod1=1.0d0
4636               uprod2=1.0d0
4637               do k=1,nbi
4638                 if (k.ne.j) then
4639                   uprod1=uprod1*u(k)
4640                   uprod2=uprod2*u(k)*u(k)
4641                 endif
4642               enddo
4643               usum=usum+uprod1
4644               usumsqder=usumsqder+ud(j)*uprod2
4645             enddo
4646 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4647 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4648             estr=estr+uprod/usum
4649             do j=1,3
4650              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4651             enddo
4652           endif
4653         endif
4654       enddo
4655       return
4656       end
4657 #ifdef CRYST_THETA
4658 C--------------------------------------------------------------------------
4659       subroutine ebend(etheta,ethetacnstr)
4660 C
4661 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4662 C angles gamma and its derivatives in consecutive thetas and gammas.
4663 C
4664       implicit real*8 (a-h,o-z)
4665       include 'DIMENSIONS'
4666       include 'sizesclu.dat'
4667       include 'COMMON.LOCAL'
4668       include 'COMMON.GEO'
4669       include 'COMMON.INTERACT'
4670       include 'COMMON.DERIV'
4671       include 'COMMON.VAR'
4672       include 'COMMON.CHAIN'
4673       include 'COMMON.IOUNITS'
4674       include 'COMMON.NAMES'
4675       include 'COMMON.FFIELD'
4676       include 'COMMON.TORCNSTR'
4677       common /calcthet/ term1,term2,termm,diffak,ratak,
4678      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4679      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4680       double precision y(2),z(2)
4681       delta=0.02d0*pi
4682 c      time11=dexp(-2*time)
4683 c      time12=1.0d0
4684       etheta=0.0D0
4685 c      write (iout,*) "nres",nres
4686 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4687 c      write (iout,*) ithet_start,ithet_end
4688       do i=ithet_start,ithet_end
4689 C        if (itype(i-1).eq.ntyp1) cycle
4690 c        if (i.le.2) cycle
4691         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4692      &  .or.itype(i).eq.ntyp1) cycle
4693 C Zero the energy function and its derivative at 0 or pi.
4694         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4695         it=itype(i-1)
4696         ichir1=isign(1,itype(i-2))
4697         ichir2=isign(1,itype(i))
4698          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4699          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4700          if (itype(i-1).eq.10) then
4701           itype1=isign(10,itype(i-2))
4702           ichir11=isign(1,itype(i-2))
4703           ichir12=isign(1,itype(i-2))
4704           itype2=isign(10,itype(i))
4705           ichir21=isign(1,itype(i))
4706           ichir22=isign(1,itype(i))
4707          endif
4708          if (i.eq.3) then
4709           y(1)=0.0D0
4710           y(2)=0.0D0
4711           else
4712
4713         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4714 #ifdef OSF
4715           phii=phi(i)
4716 c          icrc=0
4717 c          call proc_proc(phii,icrc)
4718           if (icrc.eq.1) phii=150.0
4719 #else
4720           phii=phi(i)
4721 #endif
4722           y(1)=dcos(phii)
4723           y(2)=dsin(phii)
4724         else
4725           y(1)=0.0D0
4726           y(2)=0.0D0
4727         endif
4728         endif
4729         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4730 #ifdef OSF
4731           phii1=phi(i+1)
4732 c          icrc=0
4733 c          call proc_proc(phii1,icrc)
4734           if (icrc.eq.1) phii1=150.0
4735           phii1=pinorm(phii1)
4736           z(1)=cos(phii1)
4737 #else
4738           phii1=phi(i+1)
4739           z(1)=dcos(phii1)
4740 #endif
4741           z(2)=dsin(phii1)
4742         else
4743           z(1)=0.0D0
4744           z(2)=0.0D0
4745         endif
4746 C Calculate the "mean" value of theta from the part of the distribution
4747 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4748 C In following comments this theta will be referred to as t_c.
4749         thet_pred_mean=0.0d0
4750         do k=1,2
4751             athetk=athet(k,it,ichir1,ichir2)
4752             bthetk=bthet(k,it,ichir1,ichir2)
4753           if (it.eq.10) then
4754              athetk=athet(k,itype1,ichir11,ichir12)
4755              bthetk=bthet(k,itype2,ichir21,ichir22)
4756           endif
4757           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4758         enddo
4759 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4760         dthett=thet_pred_mean*ssd
4761         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4762 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4763 C Derivatives of the "mean" values in gamma1 and gamma2.
4764         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4765      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4766          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4767      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4768          if (it.eq.10) then
4769       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4770      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4771         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4772      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4773          endif
4774         if (theta(i).gt.pi-delta) then
4775           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4776      &         E_tc0)
4777           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4778           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4779           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4780      &        E_theta)
4781           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4782      &        E_tc)
4783         else if (theta(i).lt.delta) then
4784           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4785           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4786           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4787      &        E_theta)
4788           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4789           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4790      &        E_tc)
4791         else
4792           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4793      &        E_theta,E_tc)
4794         endif
4795         etheta=etheta+ethetai
4796 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4797 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4798         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4799         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4800         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4801 c 1215   continue
4802       enddo
4803 C Ufff.... We've done all this!!!
4804 C now constrains
4805       ethetacnstr=0.0d0
4806 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4807       do i=1,ntheta_constr
4808         itheta=itheta_constr(i)
4809         thetiii=theta(itheta)
4810         difi=pinorm(thetiii-theta_constr0(i))
4811         if (difi.gt.theta_drange(i)) then
4812           difi=difi-theta_drange(i)
4813           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4814           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4815      &    +for_thet_constr(i)*difi**3
4816         else if (difi.lt.-drange(i)) then
4817           difi=difi+drange(i)
4818           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4819           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4820      &    +for_thet_constr(i)*difi**3
4821         else
4822           difi=0.0
4823         endif
4824 C       if (energy_dec) then
4825 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4826 C     &    i,itheta,rad2deg*thetiii,
4827 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4828 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4829 C     &    gloc(itheta+nphi-2,icg)
4830 C        endif
4831       enddo
4832       return
4833       end
4834 C---------------------------------------------------------------------------
4835       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4836      &     E_tc)
4837       implicit real*8 (a-h,o-z)
4838       include 'DIMENSIONS'
4839       include 'COMMON.LOCAL'
4840       include 'COMMON.IOUNITS'
4841       common /calcthet/ term1,term2,termm,diffak,ratak,
4842      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4843      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4844 C Calculate the contributions to both Gaussian lobes.
4845 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4846 C The "polynomial part" of the "standard deviation" of this part of
4847 C the distribution.
4848         sig=polthet(3,it)
4849         do j=2,0,-1
4850           sig=sig*thet_pred_mean+polthet(j,it)
4851         enddo
4852 C Derivative of the "interior part" of the "standard deviation of the"
4853 C gamma-dependent Gaussian lobe in t_c.
4854         sigtc=3*polthet(3,it)
4855         do j=2,1,-1
4856           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4857         enddo
4858         sigtc=sig*sigtc
4859 C Set the parameters of both Gaussian lobes of the distribution.
4860 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4861         fac=sig*sig+sigc0(it)
4862         sigcsq=fac+fac
4863         sigc=1.0D0/sigcsq
4864 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4865         sigsqtc=-4.0D0*sigcsq*sigtc
4866 c       print *,i,sig,sigtc,sigsqtc
4867 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4868         sigtc=-sigtc/(fac*fac)
4869 C Following variable is sigma(t_c)**(-2)
4870         sigcsq=sigcsq*sigcsq
4871         sig0i=sig0(it)
4872         sig0inv=1.0D0/sig0i**2
4873         delthec=thetai-thet_pred_mean
4874         delthe0=thetai-theta0i
4875         term1=-0.5D0*sigcsq*delthec*delthec
4876         term2=-0.5D0*sig0inv*delthe0*delthe0
4877 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4878 C NaNs in taking the logarithm. We extract the largest exponent which is added
4879 C to the energy (this being the log of the distribution) at the end of energy
4880 C term evaluation for this virtual-bond angle.
4881         if (term1.gt.term2) then
4882           termm=term1
4883           term2=dexp(term2-termm)
4884           term1=1.0d0
4885         else
4886           termm=term2
4887           term1=dexp(term1-termm)
4888           term2=1.0d0
4889         endif
4890 C The ratio between the gamma-independent and gamma-dependent lobes of
4891 C the distribution is a Gaussian function of thet_pred_mean too.
4892         diffak=gthet(2,it)-thet_pred_mean
4893         ratak=diffak/gthet(3,it)**2
4894         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4895 C Let's differentiate it in thet_pred_mean NOW.
4896         aktc=ak*ratak
4897 C Now put together the distribution terms to make complete distribution.
4898         termexp=term1+ak*term2
4899         termpre=sigc+ak*sig0i
4900 C Contribution of the bending energy from this theta is just the -log of
4901 C the sum of the contributions from the two lobes and the pre-exponential
4902 C factor. Simple enough, isn't it?
4903         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4904 C NOW the derivatives!!!
4905 C 6/6/97 Take into account the deformation.
4906         E_theta=(delthec*sigcsq*term1
4907      &       +ak*delthe0*sig0inv*term2)/termexp
4908         E_tc=((sigtc+aktc*sig0i)/termpre
4909      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4910      &       aktc*term2)/termexp)
4911       return
4912       end
4913 c-----------------------------------------------------------------------------
4914       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4915       implicit real*8 (a-h,o-z)
4916       include 'DIMENSIONS'
4917       include 'COMMON.LOCAL'
4918       include 'COMMON.IOUNITS'
4919       common /calcthet/ term1,term2,termm,diffak,ratak,
4920      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4921      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4922       delthec=thetai-thet_pred_mean
4923       delthe0=thetai-theta0i
4924 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4925       t3 = thetai-thet_pred_mean
4926       t6 = t3**2
4927       t9 = term1
4928       t12 = t3*sigcsq
4929       t14 = t12+t6*sigsqtc
4930       t16 = 1.0d0
4931       t21 = thetai-theta0i
4932       t23 = t21**2
4933       t26 = term2
4934       t27 = t21*t26
4935       t32 = termexp
4936       t40 = t32**2
4937       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4938      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4939      & *(-t12*t9-ak*sig0inv*t27)
4940       return
4941       end
4942 #else
4943 C--------------------------------------------------------------------------
4944       subroutine ebend(etheta,ethetacnstr)
4945 C
4946 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4947 C angles gamma and its derivatives in consecutive thetas and gammas.
4948 C ab initio-derived potentials from
4949 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4950 C
4951       implicit real*8 (a-h,o-z)
4952       include 'DIMENSIONS'
4953       include 'sizesclu.dat'
4954       include 'COMMON.LOCAL'
4955       include 'COMMON.GEO'
4956       include 'COMMON.INTERACT'
4957       include 'COMMON.DERIV'
4958       include 'COMMON.VAR'
4959       include 'COMMON.CHAIN'
4960       include 'COMMON.IOUNITS'
4961       include 'COMMON.NAMES'
4962       include 'COMMON.FFIELD'
4963       include 'COMMON.CONTROL'
4964       include 'COMMON.TORCNSTR'
4965       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4966      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4967      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4968      & sinph1ph2(maxdouble,maxdouble)
4969       logical lprn /.false./, lprn1 /.false./
4970       etheta=0.0D0
4971 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4972       do i=ithet_start,ithet_end
4973 c        if (i.eq.2) cycle
4974 c        print *,i,itype(i-1),itype(i),itype(i-2)
4975         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
4976      &  .or.(itype(i).eq.ntyp1)) cycle
4977 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4978
4979         if (iabs(itype(i+1)).eq.20) iblock=2
4980         if (iabs(itype(i+1)).ne.20) iblock=1
4981         dethetai=0.0d0
4982         dephii=0.0d0
4983         dephii1=0.0d0
4984         theti2=0.5d0*theta(i)
4985         ityp2=ithetyp((itype(i-1)))
4986         do k=1,nntheterm
4987           coskt(k)=dcos(k*theti2)
4988           sinkt(k)=dsin(k*theti2)
4989         enddo
4990         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4991 #ifdef OSF
4992           phii=phi(i)
4993           if (phii.ne.phii) phii=150.0
4994 #else
4995           phii=phi(i)
4996 #endif
4997           ityp1=ithetyp((itype(i-2)))
4998           do k=1,nsingle
4999             cosph1(k)=dcos(k*phii)
5000             sinph1(k)=dsin(k*phii)
5001           enddo
5002         else
5003           phii=0.0d0
5004           ityp1=ithetyp(itype(i-2))
5005           do k=1,nsingle
5006             cosph1(k)=0.0d0
5007             sinph1(k)=0.0d0
5008           enddo
5009         endif
5010         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5011 #ifdef OSF
5012           phii1=phi(i+1)
5013           if (phii1.ne.phii1) phii1=150.0
5014           phii1=pinorm(phii1)
5015 #else
5016           phii1=phi(i+1)
5017 #endif
5018           ityp3=ithetyp((itype(i)))
5019           do k=1,nsingle
5020             cosph2(k)=dcos(k*phii1)
5021             sinph2(k)=dsin(k*phii1)
5022           enddo
5023         else
5024           phii1=0.0d0
5025           ityp3=ithetyp(itype(i))
5026           do k=1,nsingle
5027             cosph2(k)=0.0d0
5028             sinph2(k)=0.0d0
5029           enddo
5030         endif
5031 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5032 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5033 c        call flush(iout)
5034         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5035         do k=1,ndouble
5036           do l=1,k-1
5037             ccl=cosph1(l)*cosph2(k-l)
5038             ssl=sinph1(l)*sinph2(k-l)
5039             scl=sinph1(l)*cosph2(k-l)
5040             csl=cosph1(l)*sinph2(k-l)
5041             cosph1ph2(l,k)=ccl-ssl
5042             cosph1ph2(k,l)=ccl+ssl
5043             sinph1ph2(l,k)=scl+csl
5044             sinph1ph2(k,l)=scl-csl
5045           enddo
5046         enddo
5047         if (lprn) then
5048         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5049      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5050         write (iout,*) "coskt and sinkt"
5051         do k=1,nntheterm
5052           write (iout,*) k,coskt(k),sinkt(k)
5053         enddo
5054         endif
5055         do k=1,ntheterm
5056           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5057           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5058      &      *coskt(k)
5059           if (lprn)
5060      &    write (iout,*) "k",k," aathet",
5061      &    aathet(k,ityp1,ityp2,ityp3,iblock),
5062      &     " ethetai",ethetai
5063         enddo
5064         if (lprn) then
5065         write (iout,*) "cosph and sinph"
5066         do k=1,nsingle
5067           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5068         enddo
5069         write (iout,*) "cosph1ph2 and sinph2ph2"
5070         do k=2,ndouble
5071           do l=1,k-1
5072             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5073      &         sinph1ph2(l,k),sinph1ph2(k,l)
5074           enddo
5075         enddo
5076         write(iout,*) "ethetai",ethetai
5077         endif
5078         do m=1,ntheterm2
5079           do k=1,nsingle
5080             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5081      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5082      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5083      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5084             ethetai=ethetai+sinkt(m)*aux
5085             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5086             dephii=dephii+k*sinkt(m)*(
5087      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5088      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5089             dephii1=dephii1+k*sinkt(m)*(
5090      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5091      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5092             if (lprn)
5093      &      write (iout,*) "m",m," k",k," bbthet",
5094      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5095      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5096      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5097      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5098           enddo
5099         enddo
5100         if (lprn)
5101      &  write(iout,*) "ethetai",ethetai
5102         do m=1,ntheterm3
5103           do k=2,ndouble
5104             do l=1,k-1
5105               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5106      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5107      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5108      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5109               ethetai=ethetai+sinkt(m)*aux
5110               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5111               dephii=dephii+l*sinkt(m)*(
5112      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5113      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5114      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5115      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5116               dephii1=dephii1+(k-l)*sinkt(m)*(
5117      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5118      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5119      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5120      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5121               if (lprn) then
5122               write (iout,*) "m",m," k",k," l",l," ffthet",
5123      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5124      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5125      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5126      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5127      &            " ethetai",ethetai
5128               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5129      &            cosph1ph2(k,l)*sinkt(m),
5130      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5131               endif
5132             enddo
5133           enddo
5134         enddo
5135 10      continue
5136         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5137      &   i,theta(i)*rad2deg,phii*rad2deg,
5138      &   phii1*rad2deg,ethetai
5139         etheta=etheta+ethetai
5140         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5141         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5142 c        gloc(nphi+i-2,icg)=wang*dethetai
5143         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5144       enddo
5145 C now constrains
5146       ethetacnstr=0.0d0
5147 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5148       do i=1,ntheta_constr
5149         itheta=itheta_constr(i)
5150         thetiii=theta(itheta)
5151         difi=pinorm(thetiii-theta_constr0(i))
5152         if (difi.gt.theta_drange(i)) then
5153           difi=difi-theta_drange(i)
5154           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5155           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5156      &    +for_thet_constr(i)*difi**3
5157         else if (difi.lt.-drange(i)) then
5158           difi=difi+drange(i)
5159           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5160           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5161      &    +for_thet_constr(i)*difi**3
5162         else
5163           difi=0.0
5164         endif
5165 C       if (energy_dec) then
5166 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5167 C     &    i,itheta,rad2deg*thetiii,
5168 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5169 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5170 C     &    gloc(itheta+nphi-2,icg)
5171 C        endif
5172       enddo
5173       return
5174       end
5175 #endif
5176 #ifdef CRYST_SC
5177 c-----------------------------------------------------------------------------
5178       subroutine esc(escloc)
5179 C Calculate the local energy of a side chain and its derivatives in the
5180 C corresponding virtual-bond valence angles THETA and the spherical angles
5181 C ALPHA and OMEGA.
5182       implicit real*8 (a-h,o-z)
5183       include 'DIMENSIONS'
5184       include 'sizesclu.dat'
5185       include 'COMMON.GEO'
5186       include 'COMMON.LOCAL'
5187       include 'COMMON.VAR'
5188       include 'COMMON.INTERACT'
5189       include 'COMMON.DERIV'
5190       include 'COMMON.CHAIN'
5191       include 'COMMON.IOUNITS'
5192       include 'COMMON.NAMES'
5193       include 'COMMON.FFIELD'
5194       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5195      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5196       common /sccalc/ time11,time12,time112,theti,it,nlobit
5197       delta=0.02d0*pi
5198       escloc=0.0D0
5199 c     write (iout,'(a)') 'ESC'
5200       do i=loc_start,loc_end
5201         it=itype(i)
5202         if (it.eq.ntyp1) cycle
5203         if (it.eq.10) goto 1
5204         nlobit=nlob(iabs(it))
5205 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5206 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5207         theti=theta(i+1)-pipol
5208         x(1)=dtan(theti)
5209         x(2)=alph(i)
5210         x(3)=omeg(i)
5211 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5212
5213         if (x(2).gt.pi-delta) then
5214           xtemp(1)=x(1)
5215           xtemp(2)=pi-delta
5216           xtemp(3)=x(3)
5217           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5218           xtemp(2)=pi
5219           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5220           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5221      &        escloci,dersc(2))
5222           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5223      &        ddersc0(1),dersc(1))
5224           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5225      &        ddersc0(3),dersc(3))
5226           xtemp(2)=pi-delta
5227           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5228           xtemp(2)=pi
5229           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5230           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5231      &            dersc0(2),esclocbi,dersc02)
5232           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5233      &            dersc12,dersc01)
5234           call splinthet(x(2),0.5d0*delta,ss,ssd)
5235           dersc0(1)=dersc01
5236           dersc0(2)=dersc02
5237           dersc0(3)=0.0d0
5238           do k=1,3
5239             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5240           enddo
5241           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5242 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5243 c    &             esclocbi,ss,ssd
5244           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5245 c         escloci=esclocbi
5246 c         write (iout,*) escloci
5247         else if (x(2).lt.delta) then
5248           xtemp(1)=x(1)
5249           xtemp(2)=delta
5250           xtemp(3)=x(3)
5251           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5252           xtemp(2)=0.0d0
5253           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5254           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5255      &        escloci,dersc(2))
5256           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5257      &        ddersc0(1),dersc(1))
5258           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5259      &        ddersc0(3),dersc(3))
5260           xtemp(2)=delta
5261           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5262           xtemp(2)=0.0d0
5263           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5264           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5265      &            dersc0(2),esclocbi,dersc02)
5266           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5267      &            dersc12,dersc01)
5268           dersc0(1)=dersc01
5269           dersc0(2)=dersc02
5270           dersc0(3)=0.0d0
5271           call splinthet(x(2),0.5d0*delta,ss,ssd)
5272           do k=1,3
5273             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5274           enddo
5275           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5276 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5277 c    &             esclocbi,ss,ssd
5278           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5279 c         write (iout,*) escloci
5280         else
5281           call enesc(x,escloci,dersc,ddummy,.false.)
5282         endif
5283
5284         escloc=escloc+escloci
5285 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5286
5287         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5288      &   wscloc*dersc(1)
5289         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5290         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5291     1   continue
5292       enddo
5293       return
5294       end
5295 C---------------------------------------------------------------------------
5296       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5297       implicit real*8 (a-h,o-z)
5298       include 'DIMENSIONS'
5299       include 'COMMON.GEO'
5300       include 'COMMON.LOCAL'
5301       include 'COMMON.IOUNITS'
5302       common /sccalc/ time11,time12,time112,theti,it,nlobit
5303       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5304       double precision contr(maxlob,-1:1)
5305       logical mixed
5306 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5307         escloc_i=0.0D0
5308         do j=1,3
5309           dersc(j)=0.0D0
5310           if (mixed) ddersc(j)=0.0d0
5311         enddo
5312         x3=x(3)
5313
5314 C Because of periodicity of the dependence of the SC energy in omega we have
5315 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5316 C To avoid underflows, first compute & store the exponents.
5317
5318         do iii=-1,1
5319
5320           x(3)=x3+iii*dwapi
5321
5322           do j=1,nlobit
5323             do k=1,3
5324               z(k)=x(k)-censc(k,j,it)
5325             enddo
5326             do k=1,3
5327               Axk=0.0D0
5328               do l=1,3
5329                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5330               enddo
5331               Ax(k,j,iii)=Axk
5332             enddo
5333             expfac=0.0D0
5334             do k=1,3
5335               expfac=expfac+Ax(k,j,iii)*z(k)
5336             enddo
5337             contr(j,iii)=expfac
5338           enddo ! j
5339
5340         enddo ! iii
5341
5342         x(3)=x3
5343 C As in the case of ebend, we want to avoid underflows in exponentiation and
5344 C subsequent NaNs and INFs in energy calculation.
5345 C Find the largest exponent
5346         emin=contr(1,-1)
5347         do iii=-1,1
5348           do j=1,nlobit
5349             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5350           enddo
5351         enddo
5352         emin=0.5D0*emin
5353 cd      print *,'it=',it,' emin=',emin
5354
5355 C Compute the contribution to SC energy and derivatives
5356         do iii=-1,1
5357
5358           do j=1,nlobit
5359             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5360 cd          print *,'j=',j,' expfac=',expfac
5361             escloc_i=escloc_i+expfac
5362             do k=1,3
5363               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5364             enddo
5365             if (mixed) then
5366               do k=1,3,2
5367                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5368      &            +gaussc(k,2,j,it))*expfac
5369               enddo
5370             endif
5371           enddo
5372
5373         enddo ! iii
5374
5375         dersc(1)=dersc(1)/cos(theti)**2
5376         ddersc(1)=ddersc(1)/cos(theti)**2
5377         ddersc(3)=ddersc(3)
5378
5379         escloci=-(dlog(escloc_i)-emin)
5380         do j=1,3
5381           dersc(j)=dersc(j)/escloc_i
5382         enddo
5383         if (mixed) then
5384           do j=1,3,2
5385             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5386           enddo
5387         endif
5388       return
5389       end
5390 C------------------------------------------------------------------------------
5391       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5392       implicit real*8 (a-h,o-z)
5393       include 'DIMENSIONS'
5394       include 'COMMON.GEO'
5395       include 'COMMON.LOCAL'
5396       include 'COMMON.IOUNITS'
5397       common /sccalc/ time11,time12,time112,theti,it,nlobit
5398       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5399       double precision contr(maxlob)
5400       logical mixed
5401
5402       escloc_i=0.0D0
5403
5404       do j=1,3
5405         dersc(j)=0.0D0
5406       enddo
5407
5408       do j=1,nlobit
5409         do k=1,2
5410           z(k)=x(k)-censc(k,j,it)
5411         enddo
5412         z(3)=dwapi
5413         do k=1,3
5414           Axk=0.0D0
5415           do l=1,3
5416             Axk=Axk+gaussc(l,k,j,it)*z(l)
5417           enddo
5418           Ax(k,j)=Axk
5419         enddo
5420         expfac=0.0D0
5421         do k=1,3
5422           expfac=expfac+Ax(k,j)*z(k)
5423         enddo
5424         contr(j)=expfac
5425       enddo ! j
5426
5427 C As in the case of ebend, we want to avoid underflows in exponentiation and
5428 C subsequent NaNs and INFs in energy calculation.
5429 C Find the largest exponent
5430       emin=contr(1)
5431       do j=1,nlobit
5432         if (emin.gt.contr(j)) emin=contr(j)
5433       enddo
5434       emin=0.5D0*emin
5435
5436 C Compute the contribution to SC energy and derivatives
5437
5438       dersc12=0.0d0
5439       do j=1,nlobit
5440         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5441         escloc_i=escloc_i+expfac
5442         do k=1,2
5443           dersc(k)=dersc(k)+Ax(k,j)*expfac
5444         enddo
5445         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5446      &            +gaussc(1,2,j,it))*expfac
5447         dersc(3)=0.0d0
5448       enddo
5449
5450       dersc(1)=dersc(1)/cos(theti)**2
5451       dersc12=dersc12/cos(theti)**2
5452       escloci=-(dlog(escloc_i)-emin)
5453       do j=1,2
5454         dersc(j)=dersc(j)/escloc_i
5455       enddo
5456       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5457       return
5458       end
5459 #else
5460 c----------------------------------------------------------------------------------
5461       subroutine esc(escloc)
5462 C Calculate the local energy of a side chain and its derivatives in the
5463 C corresponding virtual-bond valence angles THETA and the spherical angles
5464 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5465 C added by Urszula Kozlowska. 07/11/2007
5466 C
5467       implicit real*8 (a-h,o-z)
5468       include 'DIMENSIONS'
5469       include 'sizesclu.dat'
5470       include 'COMMON.GEO'
5471       include 'COMMON.LOCAL'
5472       include 'COMMON.VAR'
5473       include 'COMMON.SCROT'
5474       include 'COMMON.INTERACT'
5475       include 'COMMON.DERIV'
5476       include 'COMMON.CHAIN'
5477       include 'COMMON.IOUNITS'
5478       include 'COMMON.NAMES'
5479       include 'COMMON.FFIELD'
5480       include 'COMMON.CONTROL'
5481       include 'COMMON.VECTORS'
5482       double precision x_prime(3),y_prime(3),z_prime(3)
5483      &    , sumene,dsc_i,dp2_i,x(65),
5484      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5485      &    de_dxx,de_dyy,de_dzz,de_dt
5486       double precision s1_t,s1_6_t,s2_t,s2_6_t
5487       double precision
5488      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5489      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5490      & dt_dCi(3),dt_dCi1(3)
5491       common /sccalc/ time11,time12,time112,theti,it,nlobit
5492       delta=0.02d0*pi
5493       escloc=0.0D0
5494       do i=loc_start,loc_end
5495         if (itype(i).eq.ntyp1) cycle
5496         costtab(i+1) =dcos(theta(i+1))
5497         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5498         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5499         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5500         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5501         cosfac=dsqrt(cosfac2)
5502         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5503         sinfac=dsqrt(sinfac2)
5504         it=iabs(itype(i))
5505         if (it.eq.10) goto 1
5506 c
5507 C  Compute the axes of tghe local cartesian coordinates system; store in
5508 c   x_prime, y_prime and z_prime
5509 c
5510         do j=1,3
5511           x_prime(j) = 0.00
5512           y_prime(j) = 0.00
5513           z_prime(j) = 0.00
5514         enddo
5515 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5516 C     &   dc_norm(3,i+nres)
5517         do j = 1,3
5518           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5519           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5520         enddo
5521         do j = 1,3
5522           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5523         enddo
5524 c       write (2,*) "i",i
5525 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5526 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5527 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5528 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5529 c      & " xy",scalar(x_prime(1),y_prime(1)),
5530 c      & " xz",scalar(x_prime(1),z_prime(1)),
5531 c      & " yy",scalar(y_prime(1),y_prime(1)),
5532 c      & " yz",scalar(y_prime(1),z_prime(1)),
5533 c      & " zz",scalar(z_prime(1),z_prime(1))
5534 c
5535 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5536 C to local coordinate system. Store in xx, yy, zz.
5537 c
5538         xx=0.0d0
5539         yy=0.0d0
5540         zz=0.0d0
5541         do j = 1,3
5542           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5543           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5544           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5545         enddo
5546
5547         xxtab(i)=xx
5548         yytab(i)=yy
5549         zztab(i)=zz
5550 C
5551 C Compute the energy of the ith side cbain
5552 C
5553 c        write (2,*) "xx",xx," yy",yy," zz",zz
5554         it=iabs(itype(i))
5555         do j = 1,65
5556           x(j) = sc_parmin(j,it)
5557         enddo
5558 #ifdef CHECK_COORD
5559 Cc diagnostics - remove later
5560         xx1 = dcos(alph(2))
5561         yy1 = dsin(alph(2))*dcos(omeg(2))
5562 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
5563         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5564         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5565      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5566      &    xx1,yy1,zz1
5567 C,"  --- ", xx_w,yy_w,zz_w
5568 c end diagnostics
5569 #endif
5570         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5571      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5572      &   + x(10)*yy*zz
5573         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5574      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5575      & + x(20)*yy*zz
5576         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5577      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5578      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5579      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5580      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5581      &  +x(40)*xx*yy*zz
5582         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5583      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5584      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5585      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5586      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5587      &  +x(60)*xx*yy*zz
5588         dsc_i   = 0.743d0+x(61)
5589         dp2_i   = 1.9d0+x(62)
5590         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5591      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5592         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5593      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5594         s1=(1+x(63))/(0.1d0 + dscp1)
5595         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5596         s2=(1+x(65))/(0.1d0 + dscp2)
5597         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5598         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5599      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5600 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5601 c     &   sumene4,
5602 c     &   dscp1,dscp2,sumene
5603 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5604         escloc = escloc + sumene
5605 c        write (2,*) "escloc",escloc
5606         if (.not. calc_grad) goto 1
5607 #ifdef DEBUG
5608 C
5609 C This section to check the numerical derivatives of the energy of ith side
5610 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5611 C #define DEBUG in the code to turn it on.
5612 C
5613         write (2,*) "sumene               =",sumene
5614         aincr=1.0d-7
5615         xxsave=xx
5616         xx=xx+aincr
5617         write (2,*) xx,yy,zz
5618         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5619         de_dxx_num=(sumenep-sumene)/aincr
5620         xx=xxsave
5621         write (2,*) "xx+ sumene from enesc=",sumenep
5622         yysave=yy
5623         yy=yy+aincr
5624         write (2,*) xx,yy,zz
5625         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5626         de_dyy_num=(sumenep-sumene)/aincr
5627         yy=yysave
5628         write (2,*) "yy+ sumene from enesc=",sumenep
5629         zzsave=zz
5630         zz=zz+aincr
5631         write (2,*) xx,yy,zz
5632         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5633         de_dzz_num=(sumenep-sumene)/aincr
5634         zz=zzsave
5635         write (2,*) "zz+ sumene from enesc=",sumenep
5636         costsave=cost2tab(i+1)
5637         sintsave=sint2tab(i+1)
5638         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5639         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5640         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5641         de_dt_num=(sumenep-sumene)/aincr
5642         write (2,*) " t+ sumene from enesc=",sumenep
5643         cost2tab(i+1)=costsave
5644         sint2tab(i+1)=sintsave
5645 C End of diagnostics section.
5646 #endif
5647 C
5648 C Compute the gradient of esc
5649 C
5650         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5651         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5652         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5653         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5654         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5655         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5656         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5657         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5658         pom1=(sumene3*sint2tab(i+1)+sumene1)
5659      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5660         pom2=(sumene4*cost2tab(i+1)+sumene2)
5661      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5662         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5663         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5664      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5665      &  +x(40)*yy*zz
5666         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5667         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5668      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5669      &  +x(60)*yy*zz
5670         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5671      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5672      &        +(pom1+pom2)*pom_dx
5673 #ifdef DEBUG
5674         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5675 #endif
5676 C
5677         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5678         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5679      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5680      &  +x(40)*xx*zz
5681         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5682         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5683      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5684      &  +x(59)*zz**2 +x(60)*xx*zz
5685         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5686      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5687      &        +(pom1-pom2)*pom_dy
5688 #ifdef DEBUG
5689         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5690 #endif
5691 C
5692         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5693      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5694      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5695      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5696      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5697      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5698      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5699      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5700 #ifdef DEBUG
5701         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5702 #endif
5703 C
5704         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5705      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5706      &  +pom1*pom_dt1+pom2*pom_dt2
5707 #ifdef DEBUG
5708         write(2,*), "de_dt = ", de_dt,de_dt_num
5709 #endif
5710 c
5711 C
5712        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5713        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5714        cosfac2xx=cosfac2*xx
5715        sinfac2yy=sinfac2*yy
5716        do k = 1,3
5717          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5718      &      vbld_inv(i+1)
5719          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5720      &      vbld_inv(i)
5721          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5722          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5723 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5724 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5725 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5726 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5727          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5728          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5729          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5730          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5731          dZZ_Ci1(k)=0.0d0
5732          dZZ_Ci(k)=0.0d0
5733          do j=1,3
5734            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5735      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5736            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5737      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5738          enddo
5739
5740          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5741          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5742          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5743 c
5744          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5745          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5746        enddo
5747
5748        do k=1,3
5749          dXX_Ctab(k,i)=dXX_Ci(k)
5750          dXX_C1tab(k,i)=dXX_Ci1(k)
5751          dYY_Ctab(k,i)=dYY_Ci(k)
5752          dYY_C1tab(k,i)=dYY_Ci1(k)
5753          dZZ_Ctab(k,i)=dZZ_Ci(k)
5754          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5755          dXX_XYZtab(k,i)=dXX_XYZ(k)
5756          dYY_XYZtab(k,i)=dYY_XYZ(k)
5757          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5758        enddo
5759
5760        do k = 1,3
5761 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5762 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5763 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5764 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5765 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5766 c     &    dt_dci(k)
5767 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5768 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5769          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5770      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5771          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5772      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5773          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5774      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5775        enddo
5776 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5777 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5778
5779 C to check gradient call subroutine check_grad
5780
5781     1 continue
5782       enddo
5783       return
5784       end
5785 #endif
5786 c------------------------------------------------------------------------------
5787       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5788 C
5789 C This procedure calculates two-body contact function g(rij) and its derivative:
5790 C
5791 C           eps0ij                                     !       x < -1
5792 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5793 C            0                                         !       x > 1
5794 C
5795 C where x=(rij-r0ij)/delta
5796 C
5797 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5798 C
5799       implicit none
5800       double precision rij,r0ij,eps0ij,fcont,fprimcont
5801       double precision x,x2,x4,delta
5802 c     delta=0.02D0*r0ij
5803 c      delta=0.2D0*r0ij
5804       x=(rij-r0ij)/delta
5805       if (x.lt.-1.0D0) then
5806         fcont=eps0ij
5807         fprimcont=0.0D0
5808       else if (x.le.1.0D0) then
5809         x2=x*x
5810         x4=x2*x2
5811         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5812         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5813       else
5814         fcont=0.0D0
5815         fprimcont=0.0D0
5816       endif
5817       return
5818       end
5819 c------------------------------------------------------------------------------
5820       subroutine splinthet(theti,delta,ss,ssder)
5821       implicit real*8 (a-h,o-z)
5822       include 'DIMENSIONS'
5823       include 'sizesclu.dat'
5824       include 'COMMON.VAR'
5825       include 'COMMON.GEO'
5826       thetup=pi-delta
5827       thetlow=delta
5828       if (theti.gt.pipol) then
5829         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5830       else
5831         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5832         ssder=-ssder
5833       endif
5834       return
5835       end
5836 c------------------------------------------------------------------------------
5837       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5838       implicit none
5839       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5840       double precision ksi,ksi2,ksi3,a1,a2,a3
5841       a1=fprim0*delta/(f1-f0)
5842       a2=3.0d0-2.0d0*a1
5843       a3=a1-2.0d0
5844       ksi=(x-x0)/delta
5845       ksi2=ksi*ksi
5846       ksi3=ksi2*ksi
5847       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5848       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5849       return
5850       end
5851 c------------------------------------------------------------------------------
5852       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5853       implicit none
5854       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5855       double precision ksi,ksi2,ksi3,a1,a2,a3
5856       ksi=(x-x0)/delta
5857       ksi2=ksi*ksi
5858       ksi3=ksi2*ksi
5859       a1=fprim0x*delta
5860       a2=3*(f1x-f0x)-2*fprim0x*delta
5861       a3=fprim0x*delta-2*(f1x-f0x)
5862       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5863       return
5864       end
5865 C-----------------------------------------------------------------------------
5866 #ifdef CRYST_TOR
5867 C-----------------------------------------------------------------------------
5868       subroutine etor(etors,edihcnstr,fact)
5869       implicit real*8 (a-h,o-z)
5870       include 'DIMENSIONS'
5871       include 'sizesclu.dat'
5872       include 'COMMON.VAR'
5873       include 'COMMON.GEO'
5874       include 'COMMON.LOCAL'
5875       include 'COMMON.TORSION'
5876       include 'COMMON.INTERACT'
5877       include 'COMMON.DERIV'
5878       include 'COMMON.CHAIN'
5879       include 'COMMON.NAMES'
5880       include 'COMMON.IOUNITS'
5881       include 'COMMON.FFIELD'
5882       include 'COMMON.TORCNSTR'
5883       logical lprn
5884 C Set lprn=.true. for debugging
5885       lprn=.false.
5886 c      lprn=.true.
5887       etors=0.0D0
5888       do i=iphi_start,iphi_end
5889         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5890      &      .or. itype(i).eq.ntyp1) cycle
5891         itori=itortyp(itype(i-2))
5892         itori1=itortyp(itype(i-1))
5893         phii=phi(i)
5894         gloci=0.0D0
5895 C Proline-Proline pair is a special case...
5896         if (itori.eq.3 .and. itori1.eq.3) then
5897           if (phii.gt.-dwapi3) then
5898             cosphi=dcos(3*phii)
5899             fac=1.0D0/(1.0D0-cosphi)
5900             etorsi=v1(1,3,3)*fac
5901             etorsi=etorsi+etorsi
5902             etors=etors+etorsi-v1(1,3,3)
5903             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5904           endif
5905           do j=1,3
5906             v1ij=v1(j+1,itori,itori1)
5907             v2ij=v2(j+1,itori,itori1)
5908             cosphi=dcos(j*phii)
5909             sinphi=dsin(j*phii)
5910             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5911             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5912           enddo
5913         else
5914           do j=1,nterm_old
5915             v1ij=v1(j,itori,itori1)
5916             v2ij=v2(j,itori,itori1)
5917             cosphi=dcos(j*phii)
5918             sinphi=dsin(j*phii)
5919             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5920             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5921           enddo
5922         endif
5923         if (lprn)
5924      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5925      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5926      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5927         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5928 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5929       enddo
5930 ! 6/20/98 - dihedral angle constraints
5931       edihcnstr=0.0d0
5932       do i=1,ndih_constr
5933         itori=idih_constr(i)
5934         phii=phi(itori)
5935         difi=phii-phi0(i)
5936         if (difi.gt.drange(i)) then
5937           difi=difi-drange(i)
5938           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5939           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5940         else if (difi.lt.-drange(i)) then
5941           difi=difi+drange(i)
5942           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5943           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5944         endif
5945 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5946 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5947       enddo
5948 !      write (iout,*) 'edihcnstr',edihcnstr
5949       return
5950       end
5951 c------------------------------------------------------------------------------
5952 #else
5953       subroutine etor(etors,edihcnstr,fact)
5954       implicit real*8 (a-h,o-z)
5955       include 'DIMENSIONS'
5956       include 'sizesclu.dat'
5957       include 'COMMON.VAR'
5958       include 'COMMON.GEO'
5959       include 'COMMON.LOCAL'
5960       include 'COMMON.TORSION'
5961       include 'COMMON.INTERACT'
5962       include 'COMMON.DERIV'
5963       include 'COMMON.CHAIN'
5964       include 'COMMON.NAMES'
5965       include 'COMMON.IOUNITS'
5966       include 'COMMON.FFIELD'
5967       include 'COMMON.TORCNSTR'
5968       logical lprn
5969 C Set lprn=.true. for debugging
5970       lprn=.false.
5971 c      lprn=.true.
5972       etors=0.0D0
5973       do i=iphi_start,iphi_end
5974         if (i.le.2) cycle
5975         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5976      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5977         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5978          if (iabs(itype(i)).eq.20) then
5979          iblock=2
5980          else
5981          iblock=1
5982          endif
5983         itori=itortyp(itype(i-2))
5984         itori1=itortyp(itype(i-1))
5985         phii=phi(i)
5986         gloci=0.0D0
5987 C Regular cosine and sine terms
5988         do j=1,nterm(itori,itori1,iblock)
5989           v1ij=v1(j,itori,itori1,iblock)
5990           v2ij=v2(j,itori,itori1,iblock)
5991           cosphi=dcos(j*phii)
5992           sinphi=dsin(j*phii)
5993           etors=etors+v1ij*cosphi+v2ij*sinphi
5994           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5995         enddo
5996 C Lorentz terms
5997 C                         v1
5998 C  E = SUM ----------------------------------- - v1
5999 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6000 C
6001         cosphi=dcos(0.5d0*phii)
6002         sinphi=dsin(0.5d0*phii)
6003         do j=1,nlor(itori,itori1,iblock)
6004           vl1ij=vlor1(j,itori,itori1)
6005           vl2ij=vlor2(j,itori,itori1)
6006           vl3ij=vlor3(j,itori,itori1)
6007           pom=vl2ij*cosphi+vl3ij*sinphi
6008           pom1=1.0d0/(pom*pom+1.0d0)
6009           etors=etors+vl1ij*pom1
6010           pom=-pom*pom1*pom1
6011           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6012         enddo
6013 C Subtract the constant term
6014         etors=etors-v0(itori,itori1,iblock)
6015         if (lprn)
6016      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6017      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6018      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6019         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6020 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6021  1215   continue
6022       enddo
6023 ! 6/20/98 - dihedral angle constraints
6024       edihcnstr=0.0d0
6025       do i=1,ndih_constr
6026         itori=idih_constr(i)
6027         phii=phi(itori)
6028         difi=pinorm(phii-phi0(i))
6029         edihi=0.0d0
6030         if (difi.gt.drange(i)) then
6031           difi=difi-drange(i)
6032           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6033           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6034           edihi=0.25d0*ftors(i)*difi**4
6035         else if (difi.lt.-drange(i)) then
6036           difi=difi+drange(i)
6037           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6038           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6039           edihi=0.25d0*ftors(i)*difi**4
6040         else
6041           difi=0.0d0
6042         endif
6043 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
6044 c     &    drange(i),edihi
6045 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6046 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6047       enddo
6048 !      write (iout,*) 'edihcnstr',edihcnstr
6049       return
6050       end
6051 c----------------------------------------------------------------------------
6052       subroutine etor_d(etors_d,fact2)
6053 C 6/23/01 Compute double torsional energy
6054       implicit real*8 (a-h,o-z)
6055       include 'DIMENSIONS'
6056       include 'sizesclu.dat'
6057       include 'COMMON.VAR'
6058       include 'COMMON.GEO'
6059       include 'COMMON.LOCAL'
6060       include 'COMMON.TORSION'
6061       include 'COMMON.INTERACT'
6062       include 'COMMON.DERIV'
6063       include 'COMMON.CHAIN'
6064       include 'COMMON.NAMES'
6065       include 'COMMON.IOUNITS'
6066       include 'COMMON.FFIELD'
6067       include 'COMMON.TORCNSTR'
6068       logical lprn
6069 C Set lprn=.true. for debugging
6070       lprn=.false.
6071 c     lprn=.true.
6072       etors_d=0.0D0
6073       do i=iphi_start,iphi_end-1
6074         if (i.le.3) cycle
6075          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6076      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6077      &  (itype(i+1).eq.ntyp1)) cycle
6078         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6079      &     goto 1215
6080         itori=itortyp(itype(i-2))
6081         itori1=itortyp(itype(i-1))
6082         itori2=itortyp(itype(i))
6083         phii=phi(i)
6084         phii1=phi(i+1)
6085         gloci1=0.0D0
6086         gloci2=0.0D0
6087         iblock=1
6088         if (iabs(itype(i+1)).eq.20) iblock=2
6089 C Regular cosine and sine terms
6090        do j=1,ntermd_1(itori,itori1,itori2,iblock)
6091           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6092           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6093           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6094           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6095           cosphi1=dcos(j*phii)
6096           sinphi1=dsin(j*phii)
6097           cosphi2=dcos(j*phii1)
6098           sinphi2=dsin(j*phii1)
6099           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6100      &     v2cij*cosphi2+v2sij*sinphi2
6101           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6102           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6103         enddo
6104         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6105           do l=1,k-1
6106             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6107             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6108             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6109             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6110             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6111             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6112             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6113             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6114             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6115      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6116             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6117      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6118             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6119      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6120           enddo
6121         enddo
6122         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6123         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6124  1215   continue
6125       enddo
6126       return
6127       end
6128 #endif
6129 c------------------------------------------------------------------------------
6130       subroutine eback_sc_corr(esccor)
6131 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6132 c        conformational states; temporarily implemented as differences
6133 c        between UNRES torsional potentials (dependent on three types of
6134 c        residues) and the torsional potentials dependent on all 20 types
6135 c        of residues computed from AM1 energy surfaces of terminally-blocked
6136 c        amino-acid residues.
6137       implicit real*8 (a-h,o-z)
6138       include 'DIMENSIONS'
6139       include 'sizesclu.dat'
6140       include 'COMMON.VAR'
6141       include 'COMMON.GEO'
6142       include 'COMMON.LOCAL'
6143       include 'COMMON.TORSION'
6144       include 'COMMON.SCCOR'
6145       include 'COMMON.INTERACT'
6146       include 'COMMON.DERIV'
6147       include 'COMMON.CHAIN'
6148       include 'COMMON.NAMES'
6149       include 'COMMON.IOUNITS'
6150       include 'COMMON.FFIELD'
6151       include 'COMMON.CONTROL'
6152       logical lprn
6153 C Set lprn=.true. for debugging
6154       lprn=.false.
6155 c      lprn=.true.
6156 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6157       esccor=0.0D0
6158       do i=itau_start,itau_end
6159         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6160         esccor_ii=0.0D0
6161         isccori=isccortyp(itype(i-2))
6162         isccori1=isccortyp(itype(i-1))
6163         phii=phi(i)
6164         do intertyp=1,3 !intertyp
6165 cc Added 09 May 2012 (Adasko)
6166 cc  Intertyp means interaction type of backbone mainchain correlation:
6167 c   1 = SC...Ca...Ca...Ca
6168 c   2 = Ca...Ca...Ca...SC
6169 c   3 = SC...Ca...Ca...SCi
6170         gloci=0.0D0
6171         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6172      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6173      &      (itype(i-1).eq.ntyp1)))
6174      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6175      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6176      &     .or.(itype(i).eq.ntyp1)))
6177      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6178      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6179      &      (itype(i-3).eq.ntyp1)))) cycle
6180         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6181         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6182      & cycle
6183        do j=1,nterm_sccor(isccori,isccori1)
6184           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6185           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6186           cosphi=dcos(j*tauangle(intertyp,i))
6187           sinphi=dsin(j*tauangle(intertyp,i))
6188            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6189 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6190          enddo
6191 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
6192 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
6193         if (lprn)
6194      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6195      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6196      &  (v1sccor(j,1,itori,itori1),j=1,6),
6197      &  (v2sccor(j,1,itori,itori1),j=1,6)
6198         gsccor_loc(i-3)=gloci
6199        enddo !intertyp
6200       enddo
6201       return
6202       end
6203 c------------------------------------------------------------------------------
6204       subroutine multibody(ecorr)
6205 C This subroutine calculates multi-body contributions to energy following
6206 C the idea of Skolnick et al. If side chains I and J make a contact and
6207 C at the same time side chains I+1 and J+1 make a contact, an extra
6208 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6209       implicit real*8 (a-h,o-z)
6210       include 'DIMENSIONS'
6211       include 'COMMON.IOUNITS'
6212       include 'COMMON.DERIV'
6213       include 'COMMON.INTERACT'
6214       include 'COMMON.CONTACTS'
6215       double precision gx(3),gx1(3)
6216       logical lprn
6217
6218 C Set lprn=.true. for debugging
6219       lprn=.false.
6220
6221       if (lprn) then
6222         write (iout,'(a)') 'Contact function values:'
6223         do i=nnt,nct-2
6224           write (iout,'(i2,20(1x,i2,f10.5))')
6225      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6226         enddo
6227       endif
6228       ecorr=0.0D0
6229       do i=nnt,nct
6230         do j=1,3
6231           gradcorr(j,i)=0.0D0
6232           gradxorr(j,i)=0.0D0
6233         enddo
6234       enddo
6235       do i=nnt,nct-2
6236
6237         DO ISHIFT = 3,4
6238
6239         i1=i+ishift
6240         num_conti=num_cont(i)
6241         num_conti1=num_cont(i1)
6242         do jj=1,num_conti
6243           j=jcont(jj,i)
6244           do kk=1,num_conti1
6245             j1=jcont(kk,i1)
6246             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6247 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6248 cd   &                   ' ishift=',ishift
6249 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6250 C The system gains extra energy.
6251               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6252             endif   ! j1==j+-ishift
6253           enddo     ! kk
6254         enddo       ! jj
6255
6256         ENDDO ! ISHIFT
6257
6258       enddo         ! i
6259       return
6260       end
6261 c------------------------------------------------------------------------------
6262       double precision function esccorr(i,j,k,l,jj,kk)
6263       implicit real*8 (a-h,o-z)
6264       include 'DIMENSIONS'
6265       include 'COMMON.IOUNITS'
6266       include 'COMMON.DERIV'
6267       include 'COMMON.INTERACT'
6268       include 'COMMON.CONTACTS'
6269       double precision gx(3),gx1(3)
6270       logical lprn
6271       lprn=.false.
6272       eij=facont(jj,i)
6273       ekl=facont(kk,k)
6274 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6275 C Calculate the multi-body contribution to energy.
6276 C Calculate multi-body contributions to the gradient.
6277 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6278 cd   & k,l,(gacont(m,kk,k),m=1,3)
6279       do m=1,3
6280         gx(m) =ekl*gacont(m,jj,i)
6281         gx1(m)=eij*gacont(m,kk,k)
6282         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6283         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6284         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6285         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6286       enddo
6287       do m=i,j-1
6288         do ll=1,3
6289           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6290         enddo
6291       enddo
6292       do m=k,l-1
6293         do ll=1,3
6294           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6295         enddo
6296       enddo
6297       esccorr=-eij*ekl
6298       return
6299       end
6300 c------------------------------------------------------------------------------
6301 #ifdef MPL
6302       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6303       implicit real*8 (a-h,o-z)
6304       include 'DIMENSIONS'
6305       integer dimen1,dimen2,atom,indx
6306       double precision buffer(dimen1,dimen2)
6307       double precision zapas
6308       common /contacts_hb/ zapas(3,20,maxres,7),
6309      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6310      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6311       num_kont=num_cont_hb(atom)
6312       do i=1,num_kont
6313         do k=1,7
6314           do j=1,3
6315             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6316           enddo ! j
6317         enddo ! k
6318         buffer(i,indx+22)=facont_hb(i,atom)
6319         buffer(i,indx+23)=ees0p(i,atom)
6320         buffer(i,indx+24)=ees0m(i,atom)
6321         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6322       enddo ! i
6323       buffer(1,indx+26)=dfloat(num_kont)
6324       return
6325       end
6326 c------------------------------------------------------------------------------
6327       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6328       implicit real*8 (a-h,o-z)
6329       include 'DIMENSIONS'
6330       integer dimen1,dimen2,atom,indx
6331       double precision buffer(dimen1,dimen2)
6332       double precision zapas
6333       common /contacts_hb/ zapas(3,ntyp,maxres,7),
6334      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
6335      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
6336       num_kont=buffer(1,indx+26)
6337       num_kont_old=num_cont_hb(atom)
6338       num_cont_hb(atom)=num_kont+num_kont_old
6339       do i=1,num_kont
6340         ii=i+num_kont_old
6341         do k=1,7
6342           do j=1,3
6343             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6344           enddo ! j
6345         enddo ! k
6346         facont_hb(ii,atom)=buffer(i,indx+22)
6347         ees0p(ii,atom)=buffer(i,indx+23)
6348         ees0m(ii,atom)=buffer(i,indx+24)
6349         jcont_hb(ii,atom)=buffer(i,indx+25)
6350       enddo ! i
6351       return
6352       end
6353 c------------------------------------------------------------------------------
6354 #endif
6355       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6356 C This subroutine calculates multi-body contributions to hydrogen-bonding
6357       implicit real*8 (a-h,o-z)
6358       include 'DIMENSIONS'
6359       include 'sizesclu.dat'
6360       include 'COMMON.IOUNITS'
6361 #ifdef MPL
6362       include 'COMMON.INFO'
6363 #endif
6364       include 'COMMON.FFIELD'
6365       include 'COMMON.DERIV'
6366       include 'COMMON.INTERACT'
6367       include 'COMMON.CONTACTS'
6368 #ifdef MPL
6369       parameter (max_cont=maxconts)
6370       parameter (max_dim=2*(8*3+2))
6371       parameter (msglen1=max_cont*max_dim*4)
6372       parameter (msglen2=2*msglen1)
6373       integer source,CorrelType,CorrelID,Error
6374       double precision buffer(max_cont,max_dim)
6375 #endif
6376       double precision gx(3),gx1(3)
6377       logical lprn,ldone
6378
6379 C Set lprn=.true. for debugging
6380       lprn=.false.
6381 #ifdef MPL
6382       n_corr=0
6383       n_corr1=0
6384       if (fgProcs.le.1) goto 30
6385       if (lprn) then
6386         write (iout,'(a)') 'Contact function values:'
6387         do i=nnt,nct-2
6388           write (iout,'(2i3,50(1x,i2,f5.2))')
6389      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6390      &    j=1,num_cont_hb(i))
6391         enddo
6392       endif
6393 C Caution! Following code assumes that electrostatic interactions concerning
6394 C a given atom are split among at most two processors!
6395       CorrelType=477
6396       CorrelID=MyID+1
6397       ldone=.false.
6398       do i=1,max_cont
6399         do j=1,max_dim
6400           buffer(i,j)=0.0D0
6401         enddo
6402       enddo
6403       mm=mod(MyRank,2)
6404 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6405       if (mm) 20,20,10
6406    10 continue
6407 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6408       if (MyRank.gt.0) then
6409 C Send correlation contributions to the preceding processor
6410         msglen=msglen1
6411         nn=num_cont_hb(iatel_s)
6412         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6413 cd      write (iout,*) 'The BUFFER array:'
6414 cd      do i=1,nn
6415 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6416 cd      enddo
6417         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6418           msglen=msglen2
6419             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6420 C Clear the contacts of the atom passed to the neighboring processor
6421         nn=num_cont_hb(iatel_s+1)
6422 cd      do i=1,nn
6423 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6424 cd      enddo
6425             num_cont_hb(iatel_s)=0
6426         endif
6427 cd      write (iout,*) 'Processor ',MyID,MyRank,
6428 cd   & ' is sending correlation contribution to processor',MyID-1,
6429 cd   & ' msglen=',msglen
6430 cd      write (*,*) 'Processor ',MyID,MyRank,
6431 cd   & ' is sending correlation contribution to processor',MyID-1,
6432 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6433         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6434 cd      write (iout,*) 'Processor ',MyID,
6435 cd   & ' has sent correlation contribution to processor',MyID-1,
6436 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6437 cd      write (*,*) 'Processor ',MyID,
6438 cd   & ' has sent correlation contribution to processor',MyID-1,
6439 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6440         msglen=msglen1
6441       endif ! (MyRank.gt.0)
6442       if (ldone) goto 30
6443       ldone=.true.
6444    20 continue
6445 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6446       if (MyRank.lt.fgProcs-1) then
6447 C Receive correlation contributions from the next processor
6448         msglen=msglen1
6449         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6450 cd      write (iout,*) 'Processor',MyID,
6451 cd   & ' is receiving correlation contribution from processor',MyID+1,
6452 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6453 cd      write (*,*) 'Processor',MyID,
6454 cd   & ' is receiving correlation contribution from processor',MyID+1,
6455 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6456         nbytes=-1
6457         do while (nbytes.le.0)
6458           call mp_probe(MyID+1,CorrelType,nbytes)
6459         enddo
6460 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6461         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6462 cd      write (iout,*) 'Processor',MyID,
6463 cd   & ' has received correlation contribution from processor',MyID+1,
6464 cd   & ' msglen=',msglen,' nbytes=',nbytes
6465 cd      write (iout,*) 'The received BUFFER array:'
6466 cd      do i=1,max_cont
6467 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6468 cd      enddo
6469         if (msglen.eq.msglen1) then
6470           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6471         else if (msglen.eq.msglen2)  then
6472           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6473           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6474         else
6475           write (iout,*)
6476      & 'ERROR!!!! message length changed while processing correlations.'
6477           write (*,*)
6478      & 'ERROR!!!! message length changed while processing correlations.'
6479           call mp_stopall(Error)
6480         endif ! msglen.eq.msglen1
6481       endif ! MyRank.lt.fgProcs-1
6482       if (ldone) goto 30
6483       ldone=.true.
6484       goto 10
6485    30 continue
6486 #endif
6487       if (lprn) then
6488         write (iout,'(a)') 'Contact function values:'
6489         do i=nnt,nct-2
6490           write (iout,'(2i3,50(1x,i2,f5.2))')
6491      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6492      &    j=1,num_cont_hb(i))
6493         enddo
6494       endif
6495       ecorr=0.0D0
6496 C Remove the loop below after debugging !!!
6497       do i=nnt,nct
6498         do j=1,3
6499           gradcorr(j,i)=0.0D0
6500           gradxorr(j,i)=0.0D0
6501         enddo
6502       enddo
6503 C Calculate the local-electrostatic correlation terms
6504       do i=iatel_s,iatel_e+1
6505         i1=i+1
6506         num_conti=num_cont_hb(i)
6507         num_conti1=num_cont_hb(i+1)
6508         do jj=1,num_conti
6509           j=jcont_hb(jj,i)
6510           do kk=1,num_conti1
6511             j1=jcont_hb(kk,i1)
6512 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6513 c     &         ' jj=',jj,' kk=',kk
6514             if (j1.eq.j+1 .or. j1.eq.j-1) then
6515 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6516 C The system gains extra energy.
6517               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6518               n_corr=n_corr+1
6519             else if (j1.eq.j) then
6520 C Contacts I-J and I-(J+1) occur simultaneously.
6521 C The system loses extra energy.
6522 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6523             endif
6524           enddo ! kk
6525           do kk=1,num_conti
6526             j1=jcont_hb(kk,i)
6527 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6528 c    &         ' jj=',jj,' kk=',kk
6529             if (j1.eq.j+1) then
6530 C Contacts I-J and (I+1)-J occur simultaneously.
6531 C The system loses extra energy.
6532 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6533             endif ! j1==j+1
6534           enddo ! kk
6535         enddo ! jj
6536       enddo ! i
6537       return
6538       end
6539 c------------------------------------------------------------------------------
6540       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6541      &  n_corr1)
6542 C This subroutine calculates multi-body contributions to hydrogen-bonding
6543       implicit real*8 (a-h,o-z)
6544       include 'DIMENSIONS'
6545       include 'sizesclu.dat'
6546       include 'COMMON.IOUNITS'
6547 #ifdef MPL
6548       include 'COMMON.INFO'
6549 #endif
6550       include 'COMMON.FFIELD'
6551       include 'COMMON.DERIV'
6552       include 'COMMON.INTERACT'
6553       include 'COMMON.CONTACTS'
6554 #ifdef MPL
6555       parameter (max_cont=maxconts)
6556       parameter (max_dim=2*(8*3+2))
6557       parameter (msglen1=max_cont*max_dim*4)
6558       parameter (msglen2=2*msglen1)
6559       integer source,CorrelType,CorrelID,Error
6560       double precision buffer(max_cont,max_dim)
6561 #endif
6562       double precision gx(3),gx1(3)
6563       logical lprn,ldone
6564
6565 C Set lprn=.true. for debugging
6566       lprn=.false.
6567       eturn6=0.0d0
6568 #ifdef MPL
6569       n_corr=0
6570       n_corr1=0
6571       if (fgProcs.le.1) goto 30
6572       if (lprn) then
6573         write (iout,'(a)') 'Contact function values:'
6574         do i=nnt,nct-2
6575           write (iout,'(2i3,50(1x,i2,f5.2))')
6576      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6577      &    j=1,num_cont_hb(i))
6578         enddo
6579       endif
6580 C Caution! Following code assumes that electrostatic interactions concerning
6581 C a given atom are split among at most two processors!
6582       CorrelType=477
6583       CorrelID=MyID+1
6584       ldone=.false.
6585       do i=1,max_cont
6586         do j=1,max_dim
6587           buffer(i,j)=0.0D0
6588         enddo
6589       enddo
6590       mm=mod(MyRank,2)
6591 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6592       if (mm) 20,20,10
6593    10 continue
6594 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6595       if (MyRank.gt.0) then
6596 C Send correlation contributions to the preceding processor
6597         msglen=msglen1
6598         nn=num_cont_hb(iatel_s)
6599         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6600 cd      write (iout,*) 'The BUFFER array:'
6601 cd      do i=1,nn
6602 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6603 cd      enddo
6604         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6605           msglen=msglen2
6606             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6607 C Clear the contacts of the atom passed to the neighboring processor
6608         nn=num_cont_hb(iatel_s+1)
6609 cd      do i=1,nn
6610 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6611 cd      enddo
6612             num_cont_hb(iatel_s)=0
6613         endif
6614 cd      write (iout,*) 'Processor ',MyID,MyRank,
6615 cd   & ' is sending correlation contribution to processor',MyID-1,
6616 cd   & ' msglen=',msglen
6617 cd      write (*,*) 'Processor ',MyID,MyRank,
6618 cd   & ' is sending correlation contribution to processor',MyID-1,
6619 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6620         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6621 cd      write (iout,*) 'Processor ',MyID,
6622 cd   & ' has sent correlation contribution to processor',MyID-1,
6623 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6624 cd      write (*,*) 'Processor ',MyID,
6625 cd   & ' has sent correlation contribution to processor',MyID-1,
6626 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6627         msglen=msglen1
6628       endif ! (MyRank.gt.0)
6629       if (ldone) goto 30
6630       ldone=.true.
6631    20 continue
6632 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6633       if (MyRank.lt.fgProcs-1) then
6634 C Receive correlation contributions from the next processor
6635         msglen=msglen1
6636         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6637 cd      write (iout,*) 'Processor',MyID,
6638 cd   & ' is receiving correlation contribution from processor',MyID+1,
6639 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6640 cd      write (*,*) 'Processor',MyID,
6641 cd   & ' is receiving correlation contribution from processor',MyID+1,
6642 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6643         nbytes=-1
6644         do while (nbytes.le.0)
6645           call mp_probe(MyID+1,CorrelType,nbytes)
6646         enddo
6647 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6648         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6649 cd      write (iout,*) 'Processor',MyID,
6650 cd   & ' has received correlation contribution from processor',MyID+1,
6651 cd   & ' msglen=',msglen,' nbytes=',nbytes
6652 cd      write (iout,*) 'The received BUFFER array:'
6653 cd      do i=1,max_cont
6654 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6655 cd      enddo
6656         if (msglen.eq.msglen1) then
6657           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6658         else if (msglen.eq.msglen2)  then
6659           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6660           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6661         else
6662           write (iout,*)
6663      & 'ERROR!!!! message length changed while processing correlations.'
6664           write (*,*)
6665      & 'ERROR!!!! message length changed while processing correlations.'
6666           call mp_stopall(Error)
6667         endif ! msglen.eq.msglen1
6668       endif ! MyRank.lt.fgProcs-1
6669       if (ldone) goto 30
6670       ldone=.true.
6671       goto 10
6672    30 continue
6673 #endif
6674       if (lprn) then
6675         write (iout,'(a)') 'Contact function values:'
6676         do i=nnt,nct-2
6677           write (iout,'(2i3,50(1x,i2,f5.2))')
6678      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6679      &    j=1,num_cont_hb(i))
6680         enddo
6681       endif
6682       ecorr=0.0D0
6683       ecorr5=0.0d0
6684       ecorr6=0.0d0
6685 C Remove the loop below after debugging !!!
6686       do i=nnt,nct
6687         do j=1,3
6688           gradcorr(j,i)=0.0D0
6689           gradxorr(j,i)=0.0D0
6690         enddo
6691       enddo
6692 C Calculate the dipole-dipole interaction energies
6693       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6694       do i=iatel_s,iatel_e+1
6695         num_conti=num_cont_hb(i)
6696         do jj=1,num_conti
6697           j=jcont_hb(jj,i)
6698           call dipole(i,j,jj)
6699         enddo
6700       enddo
6701       endif
6702 C Calculate the local-electrostatic correlation terms
6703       do i=iatel_s,iatel_e+1
6704         i1=i+1
6705         num_conti=num_cont_hb(i)
6706         num_conti1=num_cont_hb(i+1)
6707         do jj=1,num_conti
6708           j=jcont_hb(jj,i)
6709           do kk=1,num_conti1
6710             j1=jcont_hb(kk,i1)
6711 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6712 c     &         ' jj=',jj,' kk=',kk
6713             if (j1.eq.j+1 .or. j1.eq.j-1) then
6714 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6715 C The system gains extra energy.
6716               n_corr=n_corr+1
6717               sqd1=dsqrt(d_cont(jj,i))
6718               sqd2=dsqrt(d_cont(kk,i1))
6719               sred_geom = sqd1*sqd2
6720               IF (sred_geom.lt.cutoff_corr) THEN
6721                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6722      &            ekont,fprimcont)
6723 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6724 c     &         ' jj=',jj,' kk=',kk
6725                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6726                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6727                 do l=1,3
6728                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6729                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6730                 enddo
6731                 n_corr1=n_corr1+1
6732 cd               write (iout,*) 'sred_geom=',sred_geom,
6733 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6734                 call calc_eello(i,j,i+1,j1,jj,kk)
6735                 if (wcorr4.gt.0.0d0)
6736      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6737                 if (wcorr5.gt.0.0d0)
6738      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6739 c                print *,"wcorr5",ecorr5
6740 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6741 cd                write(2,*)'ijkl',i,j,i+1,j1
6742                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6743      &               .or. wturn6.eq.0.0d0))then
6744 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6745                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6746 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6747 cd     &            'ecorr6=',ecorr6
6748 cd                write (iout,'(4e15.5)') sred_geom,
6749 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6750 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6751 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6752                 else if (wturn6.gt.0.0d0
6753      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6754 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6755                   eturn6=eturn6+eello_turn6(i,jj,kk)
6756 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6757                 endif
6758               ENDIF
6759 1111          continue
6760             else if (j1.eq.j) then
6761 C Contacts I-J and I-(J+1) occur simultaneously.
6762 C The system loses extra energy.
6763 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6764             endif
6765           enddo ! kk
6766           do kk=1,num_conti
6767             j1=jcont_hb(kk,i)
6768 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6769 c    &         ' jj=',jj,' kk=',kk
6770             if (j1.eq.j+1) then
6771 C Contacts I-J and (I+1)-J occur simultaneously.
6772 C The system loses extra energy.
6773 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6774             endif ! j1==j+1
6775           enddo ! kk
6776         enddo ! jj
6777       enddo ! i
6778       return
6779       end
6780 c------------------------------------------------------------------------------
6781       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6782       implicit real*8 (a-h,o-z)
6783       include 'DIMENSIONS'
6784       include 'COMMON.IOUNITS'
6785       include 'COMMON.DERIV'
6786       include 'COMMON.INTERACT'
6787       include 'COMMON.CONTACTS'
6788       include 'COMMON.SHIELD'
6789
6790       double precision gx(3),gx1(3)
6791       logical lprn
6792       lprn=.false.
6793       eij=facont_hb(jj,i)
6794       ekl=facont_hb(kk,k)
6795       ees0pij=ees0p(jj,i)
6796       ees0pkl=ees0p(kk,k)
6797       ees0mij=ees0m(jj,i)
6798       ees0mkl=ees0m(kk,k)
6799       ekont=eij*ekl
6800       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6801 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6802 C Following 4 lines for diagnostics.
6803 cd    ees0pkl=0.0D0
6804 cd    ees0pij=1.0D0
6805 cd    ees0mkl=0.0D0
6806 cd    ees0mij=1.0D0
6807 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6808 c    &   ' and',k,l
6809 c     write (iout,*)'Contacts have occurred for peptide groups',
6810 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6811 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6812 C Calculate the multi-body contribution to energy.
6813       ecorr=ecorr+ekont*ees
6814       if (calc_grad) then
6815 C Calculate multi-body contributions to the gradient.
6816       do ll=1,3
6817         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6818         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6819      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6820      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6821         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6822      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6823      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6824         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6825         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6826      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6827      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6828         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6829      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6830      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6831       enddo
6832       do m=i+1,j-1
6833         do ll=1,3
6834           gradcorr(ll,m)=gradcorr(ll,m)+
6835      &     ees*ekl*gacont_hbr(ll,jj,i)-
6836      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6837      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6838         enddo
6839       enddo
6840       do m=k+1,l-1
6841         do ll=1,3
6842           gradcorr(ll,m)=gradcorr(ll,m)+
6843      &     ees*eij*gacont_hbr(ll,kk,k)-
6844      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6845      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6846         enddo
6847       enddo
6848       if (shield_mode.gt.0) then
6849        j=ees0plist(jj,i)
6850        l=ees0plist(kk,k)
6851 C        print *,i,j,fac_shield(i),fac_shield(j),
6852 C     &fac_shield(k),fac_shield(l)
6853         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6854      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6855           do ilist=1,ishield_list(i)
6856            iresshield=shield_list(ilist,i)
6857            do m=1,3
6858            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6859 C     &      *2.0
6860            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6861      &              rlocshield
6862      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6863             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6864      &+rlocshield
6865            enddo
6866           enddo
6867           do ilist=1,ishield_list(j)
6868            iresshield=shield_list(ilist,j)
6869            do m=1,3
6870            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6871 C     &     *2.0
6872            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6873      &              rlocshield
6874      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6875            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6876      &     +rlocshield
6877            enddo
6878           enddo
6879           do ilist=1,ishield_list(k)
6880            iresshield=shield_list(ilist,k)
6881            do m=1,3
6882            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6883 C     &     *2.0
6884            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6885      &              rlocshield
6886      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6887            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6888      &     +rlocshield
6889            enddo
6890           enddo
6891           do ilist=1,ishield_list(l)
6892            iresshield=shield_list(ilist,l)
6893            do m=1,3
6894            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6895 C     &     *2.0
6896            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6897      &              rlocshield
6898      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6899            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6900      &     +rlocshield
6901            enddo
6902           enddo
6903 C          print *,gshieldx(m,iresshield)
6904           do m=1,3
6905             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6906      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6907             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6908      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6909             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6910      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6911             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6912      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6913
6914             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6915      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6916             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6917      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6918             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6919      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6920             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6921      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6922
6923            enddo
6924       endif
6925       endif
6926       endif
6927       ehbcorr=ekont*ees
6928       return
6929       end
6930 C---------------------------------------------------------------------------
6931       subroutine dipole(i,j,jj)
6932       implicit real*8 (a-h,o-z)
6933       include 'DIMENSIONS'
6934       include 'sizesclu.dat'
6935       include 'COMMON.IOUNITS'
6936       include 'COMMON.CHAIN'
6937       include 'COMMON.FFIELD'
6938       include 'COMMON.DERIV'
6939       include 'COMMON.INTERACT'
6940       include 'COMMON.CONTACTS'
6941       include 'COMMON.TORSION'
6942       include 'COMMON.VAR'
6943       include 'COMMON.GEO'
6944       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6945      &  auxmat(2,2)
6946       iti1 = itortyp(itype(i+1))
6947       if (j.lt.nres-1) then
6948         if (itype(j).le.ntyp) then
6949           itj1 = itortyp(itype(j+1))
6950         else
6951           itj1=ntortyp+1
6952         endif
6953       else
6954         itj1=ntortyp+1
6955       endif
6956       do iii=1,2
6957         dipi(iii,1)=Ub2(iii,i)
6958         dipderi(iii)=Ub2der(iii,i)
6959         dipi(iii,2)=b1(iii,iti1)
6960         dipj(iii,1)=Ub2(iii,j)
6961         dipderj(iii)=Ub2der(iii,j)
6962         dipj(iii,2)=b1(iii,itj1)
6963       enddo
6964       kkk=0
6965       do iii=1,2
6966         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6967         do jjj=1,2
6968           kkk=kkk+1
6969           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6970         enddo
6971       enddo
6972       if (.not.calc_grad) return
6973       do kkk=1,5
6974         do lll=1,3
6975           mmm=0
6976           do iii=1,2
6977             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6978      &        auxvec(1))
6979             do jjj=1,2
6980               mmm=mmm+1
6981               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6982             enddo
6983           enddo
6984         enddo
6985       enddo
6986       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6987       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6988       do iii=1,2
6989         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6990       enddo
6991       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6992       do iii=1,2
6993         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6994       enddo
6995       return
6996       end
6997 C---------------------------------------------------------------------------
6998       subroutine calc_eello(i,j,k,l,jj,kk)
6999 C
7000 C This subroutine computes matrices and vectors needed to calculate
7001 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7002 C
7003       implicit real*8 (a-h,o-z)
7004       include 'DIMENSIONS'
7005       include 'sizesclu.dat'
7006       include 'COMMON.IOUNITS'
7007       include 'COMMON.CHAIN'
7008       include 'COMMON.DERIV'
7009       include 'COMMON.INTERACT'
7010       include 'COMMON.CONTACTS'
7011       include 'COMMON.TORSION'
7012       include 'COMMON.VAR'
7013       include 'COMMON.GEO'
7014       include 'COMMON.FFIELD'
7015       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7016      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7017       logical lprn
7018       common /kutas/ lprn
7019 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7020 cd     & ' jj=',jj,' kk=',kk
7021 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7022       do iii=1,2
7023         do jjj=1,2
7024           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7025           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7026         enddo
7027       enddo
7028       call transpose2(aa1(1,1),aa1t(1,1))
7029       call transpose2(aa2(1,1),aa2t(1,1))
7030       do kkk=1,5
7031         do lll=1,3
7032           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7033      &      aa1tder(1,1,lll,kkk))
7034           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7035      &      aa2tder(1,1,lll,kkk))
7036         enddo
7037       enddo
7038       if (l.eq.j+1) then
7039 C parallel orientation of the two CA-CA-CA frames.
7040 c        if (i.gt.1) then
7041         if (i.gt.1 .and. itype(i).le.ntyp) then
7042           iti=itortyp(itype(i))
7043         else
7044           iti=ntortyp+1
7045         endif
7046         itk1=itortyp(itype(k+1))
7047         itj=itortyp(itype(j))
7048 c        if (l.lt.nres-1) then
7049         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7050           itl1=itortyp(itype(l+1))
7051         else
7052           itl1=ntortyp+1
7053         endif
7054 C A1 kernel(j+1) A2T
7055 cd        do iii=1,2
7056 cd          write (iout,'(3f10.5,5x,3f10.5)')
7057 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7058 cd        enddo
7059         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7060      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7061      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7062 C Following matrices are needed only for 6-th order cumulants
7063         IF (wcorr6.gt.0.0d0) THEN
7064         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7065      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7066      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7067         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7068      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7069      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7070      &   ADtEAderx(1,1,1,1,1,1))
7071         lprn=.false.
7072         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7073      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7074      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7075      &   ADtEA1derx(1,1,1,1,1,1))
7076         ENDIF
7077 C End 6-th order cumulants
7078 cd        lprn=.false.
7079 cd        if (lprn) then
7080 cd        write (2,*) 'In calc_eello6'
7081 cd        do iii=1,2
7082 cd          write (2,*) 'iii=',iii
7083 cd          do kkk=1,5
7084 cd            write (2,*) 'kkk=',kkk
7085 cd            do jjj=1,2
7086 cd              write (2,'(3(2f10.5),5x)')
7087 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7088 cd            enddo
7089 cd          enddo
7090 cd        enddo
7091 cd        endif
7092         call transpose2(EUgder(1,1,k),auxmat(1,1))
7093         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7094         call transpose2(EUg(1,1,k),auxmat(1,1))
7095         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7096         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7097         do iii=1,2
7098           do kkk=1,5
7099             do lll=1,3
7100               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7101      &          EAEAderx(1,1,lll,kkk,iii,1))
7102             enddo
7103           enddo
7104         enddo
7105 C A1T kernel(i+1) A2
7106         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7107      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7108      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7109 C Following matrices are needed only for 6-th order cumulants
7110         IF (wcorr6.gt.0.0d0) THEN
7111         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7112      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7113      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7114         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7115      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7116      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7117      &   ADtEAderx(1,1,1,1,1,2))
7118         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7119      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7120      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7121      &   ADtEA1derx(1,1,1,1,1,2))
7122         ENDIF
7123 C End 6-th order cumulants
7124         call transpose2(EUgder(1,1,l),auxmat(1,1))
7125         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7126         call transpose2(EUg(1,1,l),auxmat(1,1))
7127         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7128         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7129         do iii=1,2
7130           do kkk=1,5
7131             do lll=1,3
7132               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7133      &          EAEAderx(1,1,lll,kkk,iii,2))
7134             enddo
7135           enddo
7136         enddo
7137 C AEAb1 and AEAb2
7138 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7139 C They are needed only when the fifth- or the sixth-order cumulants are
7140 C indluded.
7141         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7142         call transpose2(AEA(1,1,1),auxmat(1,1))
7143         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7144         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7145         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7146         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7147         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7148         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7149         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7150         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7151         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7152         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7153         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7154         call transpose2(AEA(1,1,2),auxmat(1,1))
7155         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7156         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7157         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7158         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7159         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7160         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7161         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7162         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7163         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7164         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7165         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7166 C Calculate the Cartesian derivatives of the vectors.
7167         do iii=1,2
7168           do kkk=1,5
7169             do lll=1,3
7170               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7171               call matvec2(auxmat(1,1),b1(1,iti),
7172      &          AEAb1derx(1,lll,kkk,iii,1,1))
7173               call matvec2(auxmat(1,1),Ub2(1,i),
7174      &          AEAb2derx(1,lll,kkk,iii,1,1))
7175               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7176      &          AEAb1derx(1,lll,kkk,iii,2,1))
7177               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7178      &          AEAb2derx(1,lll,kkk,iii,2,1))
7179               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7180               call matvec2(auxmat(1,1),b1(1,itj),
7181      &          AEAb1derx(1,lll,kkk,iii,1,2))
7182               call matvec2(auxmat(1,1),Ub2(1,j),
7183      &          AEAb2derx(1,lll,kkk,iii,1,2))
7184               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7185      &          AEAb1derx(1,lll,kkk,iii,2,2))
7186               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7187      &          AEAb2derx(1,lll,kkk,iii,2,2))
7188             enddo
7189           enddo
7190         enddo
7191         ENDIF
7192 C End vectors
7193       else
7194 C Antiparallel orientation of the two CA-CA-CA frames.
7195 c        if (i.gt.1) then
7196         if (i.gt.1 .and. itype(i).le.ntyp) then
7197           iti=itortyp(itype(i))
7198         else
7199           iti=ntortyp+1
7200         endif
7201         itk1=itortyp(itype(k+1))
7202         itl=itortyp(itype(l))
7203         itj=itortyp(itype(j))
7204 c        if (j.lt.nres-1) then
7205         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7206           itj1=itortyp(itype(j+1))
7207         else
7208           itj1=ntortyp+1
7209         endif
7210 C A2 kernel(j-1)T A1T
7211         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7212      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7213      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7214 C Following matrices are needed only for 6-th order cumulants
7215         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7216      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7217         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7218      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7219      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7220         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7221      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7222      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7223      &   ADtEAderx(1,1,1,1,1,1))
7224         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7225      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7226      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7227      &   ADtEA1derx(1,1,1,1,1,1))
7228         ENDIF
7229 C End 6-th order cumulants
7230         call transpose2(EUgder(1,1,k),auxmat(1,1))
7231         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7232         call transpose2(EUg(1,1,k),auxmat(1,1))
7233         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7234         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7235         do iii=1,2
7236           do kkk=1,5
7237             do lll=1,3
7238               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7239      &          EAEAderx(1,1,lll,kkk,iii,1))
7240             enddo
7241           enddo
7242         enddo
7243 C A2T kernel(i+1)T A1
7244         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7245      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7246      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7247 C Following matrices are needed only for 6-th order cumulants
7248         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7249      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7250         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7251      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7252      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7253         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7254      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7255      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7256      &   ADtEAderx(1,1,1,1,1,2))
7257         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7258      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7259      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7260      &   ADtEA1derx(1,1,1,1,1,2))
7261         ENDIF
7262 C End 6-th order cumulants
7263         call transpose2(EUgder(1,1,j),auxmat(1,1))
7264         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7265         call transpose2(EUg(1,1,j),auxmat(1,1))
7266         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7267         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7268         do iii=1,2
7269           do kkk=1,5
7270             do lll=1,3
7271               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7272      &          EAEAderx(1,1,lll,kkk,iii,2))
7273             enddo
7274           enddo
7275         enddo
7276 C AEAb1 and AEAb2
7277 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7278 C They are needed only when the fifth- or the sixth-order cumulants are
7279 C indluded.
7280         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7281      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7282         call transpose2(AEA(1,1,1),auxmat(1,1))
7283         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7284         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7285         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7286         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7287         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7288         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7289         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7290         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7291         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7292         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7293         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7294         call transpose2(AEA(1,1,2),auxmat(1,1))
7295         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7296         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7297         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7298         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7299         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7300         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7301         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7302         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7303         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7304         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7305         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7306 C Calculate the Cartesian derivatives of the vectors.
7307         do iii=1,2
7308           do kkk=1,5
7309             do lll=1,3
7310               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7311               call matvec2(auxmat(1,1),b1(1,iti),
7312      &          AEAb1derx(1,lll,kkk,iii,1,1))
7313               call matvec2(auxmat(1,1),Ub2(1,i),
7314      &          AEAb2derx(1,lll,kkk,iii,1,1))
7315               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7316      &          AEAb1derx(1,lll,kkk,iii,2,1))
7317               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7318      &          AEAb2derx(1,lll,kkk,iii,2,1))
7319               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7320               call matvec2(auxmat(1,1),b1(1,itl),
7321      &          AEAb1derx(1,lll,kkk,iii,1,2))
7322               call matvec2(auxmat(1,1),Ub2(1,l),
7323      &          AEAb2derx(1,lll,kkk,iii,1,2))
7324               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7325      &          AEAb1derx(1,lll,kkk,iii,2,2))
7326               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7327      &          AEAb2derx(1,lll,kkk,iii,2,2))
7328             enddo
7329           enddo
7330         enddo
7331         ENDIF
7332 C End vectors
7333       endif
7334       return
7335       end
7336 C---------------------------------------------------------------------------
7337       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7338      &  KK,KKderg,AKA,AKAderg,AKAderx)
7339       implicit none
7340       integer nderg
7341       logical transp
7342       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7343      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7344      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7345       integer iii,kkk,lll
7346       integer jjj,mmm
7347       logical lprn
7348       common /kutas/ lprn
7349       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7350       do iii=1,nderg
7351         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7352      &    AKAderg(1,1,iii))
7353       enddo
7354 cd      if (lprn) write (2,*) 'In kernel'
7355       do kkk=1,5
7356 cd        if (lprn) write (2,*) 'kkk=',kkk
7357         do lll=1,3
7358           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7359      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7360 cd          if (lprn) then
7361 cd            write (2,*) 'lll=',lll
7362 cd            write (2,*) 'iii=1'
7363 cd            do jjj=1,2
7364 cd              write (2,'(3(2f10.5),5x)')
7365 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7366 cd            enddo
7367 cd          endif
7368           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7369      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7370 cd          if (lprn) then
7371 cd            write (2,*) 'lll=',lll
7372 cd            write (2,*) 'iii=2'
7373 cd            do jjj=1,2
7374 cd              write (2,'(3(2f10.5),5x)')
7375 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7376 cd            enddo
7377 cd          endif
7378         enddo
7379       enddo
7380       return
7381       end
7382 C---------------------------------------------------------------------------
7383       double precision function eello4(i,j,k,l,jj,kk)
7384       implicit real*8 (a-h,o-z)
7385       include 'DIMENSIONS'
7386       include 'sizesclu.dat'
7387       include 'COMMON.IOUNITS'
7388       include 'COMMON.CHAIN'
7389       include 'COMMON.DERIV'
7390       include 'COMMON.INTERACT'
7391       include 'COMMON.CONTACTS'
7392       include 'COMMON.TORSION'
7393       include 'COMMON.VAR'
7394       include 'COMMON.GEO'
7395       double precision pizda(2,2),ggg1(3),ggg2(3)
7396 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7397 cd        eello4=0.0d0
7398 cd        return
7399 cd      endif
7400 cd      print *,'eello4:',i,j,k,l,jj,kk
7401 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7402 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7403 cold      eij=facont_hb(jj,i)
7404 cold      ekl=facont_hb(kk,k)
7405 cold      ekont=eij*ekl
7406       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7407       if (calc_grad) then
7408 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7409       gcorr_loc(k-1)=gcorr_loc(k-1)
7410      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7411       if (l.eq.j+1) then
7412         gcorr_loc(l-1)=gcorr_loc(l-1)
7413      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7414       else
7415         gcorr_loc(j-1)=gcorr_loc(j-1)
7416      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7417       endif
7418       do iii=1,2
7419         do kkk=1,5
7420           do lll=1,3
7421             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7422      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7423 cd            derx(lll,kkk,iii)=0.0d0
7424           enddo
7425         enddo
7426       enddo
7427 cd      gcorr_loc(l-1)=0.0d0
7428 cd      gcorr_loc(j-1)=0.0d0
7429 cd      gcorr_loc(k-1)=0.0d0
7430 cd      eel4=1.0d0
7431 cd      write (iout,*)'Contacts have occurred for peptide groups',
7432 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7433 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7434       if (j.lt.nres-1) then
7435         j1=j+1
7436         j2=j-1
7437       else
7438         j1=j-1
7439         j2=j-2
7440       endif
7441       if (l.lt.nres-1) then
7442         l1=l+1
7443         l2=l-1
7444       else
7445         l1=l-1
7446         l2=l-2
7447       endif
7448       do ll=1,3
7449 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7450         ggg1(ll)=eel4*g_contij(ll,1)
7451         ggg2(ll)=eel4*g_contij(ll,2)
7452         ghalf=0.5d0*ggg1(ll)
7453 cd        ghalf=0.0d0
7454         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7455         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7456         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7457         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7458 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7459         ghalf=0.5d0*ggg2(ll)
7460 cd        ghalf=0.0d0
7461         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7462         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7463         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7464         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7465       enddo
7466 cd      goto 1112
7467       do m=i+1,j-1
7468         do ll=1,3
7469 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7470           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7471         enddo
7472       enddo
7473       do m=k+1,l-1
7474         do ll=1,3
7475 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7476           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7477         enddo
7478       enddo
7479 1112  continue
7480       do m=i+2,j2
7481         do ll=1,3
7482           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7483         enddo
7484       enddo
7485       do m=k+2,l2
7486         do ll=1,3
7487           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7488         enddo
7489       enddo
7490 cd      do iii=1,nres-3
7491 cd        write (2,*) iii,gcorr_loc(iii)
7492 cd      enddo
7493       endif
7494       eello4=ekont*eel4
7495 cd      write (2,*) 'ekont',ekont
7496 cd      write (iout,*) 'eello4',ekont*eel4
7497       return
7498       end
7499 C---------------------------------------------------------------------------
7500       double precision function eello5(i,j,k,l,jj,kk)
7501       implicit real*8 (a-h,o-z)
7502       include 'DIMENSIONS'
7503       include 'sizesclu.dat'
7504       include 'COMMON.IOUNITS'
7505       include 'COMMON.CHAIN'
7506       include 'COMMON.DERIV'
7507       include 'COMMON.INTERACT'
7508       include 'COMMON.CONTACTS'
7509       include 'COMMON.TORSION'
7510       include 'COMMON.VAR'
7511       include 'COMMON.GEO'
7512       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7513       double precision ggg1(3),ggg2(3)
7514 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7515 C                                                                              C
7516 C                            Parallel chains                                   C
7517 C                                                                              C
7518 C          o             o                   o             o                   C
7519 C         /l\           / \             \   / \           / \   /              C
7520 C        /   \         /   \             \ /   \         /   \ /               C
7521 C       j| o |l1       | 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                            Antiparallel chains                               C
7530 C                                                                              C
7531 C          o             o                   o             o                   C
7532 C         /j\           / \             \   / \           / \   /              C
7533 C        /   \         /   \             \ /   \         /   \ /               C
7534 C      j1| o |l        | o |              o| o |         | o |o                C
7535 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7536 C      \i/   \         /   \ /             /   \         /   \                 C
7537 C       o     k1            o                                                  C
7538 C         (I)          (II)                (III)          (IV)                 C
7539 C                                                                              C
7540 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7541 C                                                                              C
7542 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7543 C                                                                              C
7544 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7545 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7546 cd        eello5=0.0d0
7547 cd        return
7548 cd      endif
7549 cd      write (iout,*)
7550 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7551 cd     &   ' and',k,l
7552       itk=itortyp(itype(k))
7553       itl=itortyp(itype(l))
7554       itj=itortyp(itype(j))
7555       eello5_1=0.0d0
7556       eello5_2=0.0d0
7557       eello5_3=0.0d0
7558       eello5_4=0.0d0
7559 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7560 cd     &   eel5_3_num,eel5_4_num)
7561       do iii=1,2
7562         do kkk=1,5
7563           do lll=1,3
7564             derx(lll,kkk,iii)=0.0d0
7565           enddo
7566         enddo
7567       enddo
7568 cd      eij=facont_hb(jj,i)
7569 cd      ekl=facont_hb(kk,k)
7570 cd      ekont=eij*ekl
7571 cd      write (iout,*)'Contacts have occurred for peptide groups',
7572 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7573 cd      goto 1111
7574 C Contribution from the graph I.
7575 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7576 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7577       call transpose2(EUg(1,1,k),auxmat(1,1))
7578       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7579       vv(1)=pizda(1,1)-pizda(2,2)
7580       vv(2)=pizda(1,2)+pizda(2,1)
7581       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7582      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7583       if (calc_grad) then
7584 C Explicit gradient in virtual-dihedral angles.
7585       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7586      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7587      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7588       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7589       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7590       vv(1)=pizda(1,1)-pizda(2,2)
7591       vv(2)=pizda(1,2)+pizda(2,1)
7592       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7593      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7594      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7595       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7596       vv(1)=pizda(1,1)-pizda(2,2)
7597       vv(2)=pizda(1,2)+pizda(2,1)
7598       if (l.eq.j+1) then
7599         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7600      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7601      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7602       else
7603         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7604      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7605      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7606       endif
7607 C Cartesian gradient
7608       do iii=1,2
7609         do kkk=1,5
7610           do lll=1,3
7611             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7612      &        pizda(1,1))
7613             vv(1)=pizda(1,1)-pizda(2,2)
7614             vv(2)=pizda(1,2)+pizda(2,1)
7615             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7616      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7617      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7618           enddo
7619         enddo
7620       enddo
7621 c      goto 1112
7622       endif
7623 c1111  continue
7624 C Contribution from graph II
7625       call transpose2(EE(1,1,itk),auxmat(1,1))
7626       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7627       vv(1)=pizda(1,1)+pizda(2,2)
7628       vv(2)=pizda(2,1)-pizda(1,2)
7629       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7630      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7631       if (calc_grad) then
7632 C Explicit gradient in virtual-dihedral angles.
7633       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7634      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7635       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7636       vv(1)=pizda(1,1)+pizda(2,2)
7637       vv(2)=pizda(2,1)-pizda(1,2)
7638       if (l.eq.j+1) then
7639         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7640      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7641      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7642       else
7643         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7644      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7645      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7646       endif
7647 C Cartesian gradient
7648       do iii=1,2
7649         do kkk=1,5
7650           do lll=1,3
7651             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7652      &        pizda(1,1))
7653             vv(1)=pizda(1,1)+pizda(2,2)
7654             vv(2)=pizda(2,1)-pizda(1,2)
7655             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7656      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7657      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7658           enddo
7659         enddo
7660       enddo
7661 cd      goto 1112
7662       endif
7663 cd1111  continue
7664       if (l.eq.j+1) then
7665 cd        goto 1110
7666 C Parallel orientation
7667 C Contribution from graph III
7668         call transpose2(EUg(1,1,l),auxmat(1,1))
7669         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7670         vv(1)=pizda(1,1)-pizda(2,2)
7671         vv(2)=pizda(1,2)+pizda(2,1)
7672         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7673      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7674         if (calc_grad) then
7675 C Explicit gradient in virtual-dihedral angles.
7676         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7677      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7678      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7679         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7680         vv(1)=pizda(1,1)-pizda(2,2)
7681         vv(2)=pizda(1,2)+pizda(2,1)
7682         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7683      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7684      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7685         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7686         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7687         vv(1)=pizda(1,1)-pizda(2,2)
7688         vv(2)=pizda(1,2)+pizda(2,1)
7689         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7690      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7691      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7692 C Cartesian gradient
7693         do iii=1,2
7694           do kkk=1,5
7695             do lll=1,3
7696               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7697      &          pizda(1,1))
7698               vv(1)=pizda(1,1)-pizda(2,2)
7699               vv(2)=pizda(1,2)+pizda(2,1)
7700               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7701      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7702      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7703             enddo
7704           enddo
7705         enddo
7706 cd        goto 1112
7707         endif
7708 C Contribution from graph IV
7709 cd1110    continue
7710         call transpose2(EE(1,1,itl),auxmat(1,1))
7711         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7712         vv(1)=pizda(1,1)+pizda(2,2)
7713         vv(2)=pizda(2,1)-pizda(1,2)
7714         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7715      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7716         if (calc_grad) then
7717 C Explicit gradient in virtual-dihedral angles.
7718         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7719      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7720         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7721         vv(1)=pizda(1,1)+pizda(2,2)
7722         vv(2)=pizda(2,1)-pizda(1,2)
7723         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7724      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7725      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7726 C Cartesian gradient
7727         do iii=1,2
7728           do kkk=1,5
7729             do lll=1,3
7730               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7731      &          pizda(1,1))
7732               vv(1)=pizda(1,1)+pizda(2,2)
7733               vv(2)=pizda(2,1)-pizda(1,2)
7734               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7735      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7736      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7737             enddo
7738           enddo
7739         enddo
7740         endif
7741       else
7742 C Antiparallel orientation
7743 C Contribution from graph III
7744 c        goto 1110
7745         call transpose2(EUg(1,1,j),auxmat(1,1))
7746         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7747         vv(1)=pizda(1,1)-pizda(2,2)
7748         vv(2)=pizda(1,2)+pizda(2,1)
7749         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7750      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7751         if (calc_grad) then
7752 C Explicit gradient in virtual-dihedral angles.
7753         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7754      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7755      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7756         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7757         vv(1)=pizda(1,1)-pizda(2,2)
7758         vv(2)=pizda(1,2)+pizda(2,1)
7759         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7760      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7761      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7762         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7763         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7764         vv(1)=pizda(1,1)-pizda(2,2)
7765         vv(2)=pizda(1,2)+pizda(2,1)
7766         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7767      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7768      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7769 C Cartesian gradient
7770         do iii=1,2
7771           do kkk=1,5
7772             do lll=1,3
7773               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7774      &          pizda(1,1))
7775               vv(1)=pizda(1,1)-pizda(2,2)
7776               vv(2)=pizda(1,2)+pizda(2,1)
7777               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7778      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7779      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7780             enddo
7781           enddo
7782         enddo
7783 cd        goto 1112
7784         endif
7785 C Contribution from graph IV
7786 1110    continue
7787         call transpose2(EE(1,1,itj),auxmat(1,1))
7788         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7789         vv(1)=pizda(1,1)+pizda(2,2)
7790         vv(2)=pizda(2,1)-pizda(1,2)
7791         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7792      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7793         if (calc_grad) then
7794 C Explicit gradient in virtual-dihedral angles.
7795         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7796      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7797         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7798         vv(1)=pizda(1,1)+pizda(2,2)
7799         vv(2)=pizda(2,1)-pizda(1,2)
7800         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7801      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7802      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7803 C Cartesian gradient
7804         do iii=1,2
7805           do kkk=1,5
7806             do lll=1,3
7807               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7808      &          pizda(1,1))
7809               vv(1)=pizda(1,1)+pizda(2,2)
7810               vv(2)=pizda(2,1)-pizda(1,2)
7811               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7812      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7813      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7814             enddo
7815           enddo
7816         enddo
7817       endif
7818       endif
7819 1112  continue
7820       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7821 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7822 cd        write (2,*) 'ijkl',i,j,k,l
7823 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7824 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7825 cd      endif
7826 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7827 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7828 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7829 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7830       if (calc_grad) then
7831       if (j.lt.nres-1) then
7832         j1=j+1
7833         j2=j-1
7834       else
7835         j1=j-1
7836         j2=j-2
7837       endif
7838       if (l.lt.nres-1) then
7839         l1=l+1
7840         l2=l-1
7841       else
7842         l1=l-1
7843         l2=l-2
7844       endif
7845 cd      eij=1.0d0
7846 cd      ekl=1.0d0
7847 cd      ekont=1.0d0
7848 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7849       do ll=1,3
7850         ggg1(ll)=eel5*g_contij(ll,1)
7851         ggg2(ll)=eel5*g_contij(ll,2)
7852 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7853         ghalf=0.5d0*ggg1(ll)
7854 cd        ghalf=0.0d0
7855         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7856         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7857         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7858         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7859 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7860         ghalf=0.5d0*ggg2(ll)
7861 cd        ghalf=0.0d0
7862         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7863         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7864         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7865         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7866       enddo
7867 cd      goto 1112
7868       do m=i+1,j-1
7869         do ll=1,3
7870 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7871           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7872         enddo
7873       enddo
7874       do m=k+1,l-1
7875         do ll=1,3
7876 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7877           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7878         enddo
7879       enddo
7880 c1112  continue
7881       do m=i+2,j2
7882         do ll=1,3
7883           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7884         enddo
7885       enddo
7886       do m=k+2,l2
7887         do ll=1,3
7888           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7889         enddo
7890       enddo
7891 cd      do iii=1,nres-3
7892 cd        write (2,*) iii,g_corr5_loc(iii)
7893 cd      enddo
7894       endif
7895       eello5=ekont*eel5
7896 cd      write (2,*) 'ekont',ekont
7897 cd      write (iout,*) 'eello5',ekont*eel5
7898       return
7899       end
7900 c--------------------------------------------------------------------------
7901       double precision function eello6(i,j,k,l,jj,kk)
7902       implicit real*8 (a-h,o-z)
7903       include 'DIMENSIONS'
7904       include 'sizesclu.dat'
7905       include 'COMMON.IOUNITS'
7906       include 'COMMON.CHAIN'
7907       include 'COMMON.DERIV'
7908       include 'COMMON.INTERACT'
7909       include 'COMMON.CONTACTS'
7910       include 'COMMON.TORSION'
7911       include 'COMMON.VAR'
7912       include 'COMMON.GEO'
7913       include 'COMMON.FFIELD'
7914       double precision ggg1(3),ggg2(3)
7915 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7916 cd        eello6=0.0d0
7917 cd        return
7918 cd      endif
7919 cd      write (iout,*)
7920 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7921 cd     &   ' and',k,l
7922       eello6_1=0.0d0
7923       eello6_2=0.0d0
7924       eello6_3=0.0d0
7925       eello6_4=0.0d0
7926       eello6_5=0.0d0
7927       eello6_6=0.0d0
7928 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7929 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7930       do iii=1,2
7931         do kkk=1,5
7932           do lll=1,3
7933             derx(lll,kkk,iii)=0.0d0
7934           enddo
7935         enddo
7936       enddo
7937 cd      eij=facont_hb(jj,i)
7938 cd      ekl=facont_hb(kk,k)
7939 cd      ekont=eij*ekl
7940 cd      eij=1.0d0
7941 cd      ekl=1.0d0
7942 cd      ekont=1.0d0
7943       if (l.eq.j+1) then
7944         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7945         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7946         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7947         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7948         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7949         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7950       else
7951         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7952         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7953         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7954         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7955         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7956           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7957         else
7958           eello6_5=0.0d0
7959         endif
7960         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7961       endif
7962 C If turn contributions are considered, they will be handled separately.
7963       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7964 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7965 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7966 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7967 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7968 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7969 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7970 cd      goto 1112
7971       if (calc_grad) then
7972       if (j.lt.nres-1) then
7973         j1=j+1
7974         j2=j-1
7975       else
7976         j1=j-1
7977         j2=j-2
7978       endif
7979       if (l.lt.nres-1) then
7980         l1=l+1
7981         l2=l-1
7982       else
7983         l1=l-1
7984         l2=l-2
7985       endif
7986       do ll=1,3
7987         ggg1(ll)=eel6*g_contij(ll,1)
7988         ggg2(ll)=eel6*g_contij(ll,2)
7989 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7990         ghalf=0.5d0*ggg1(ll)
7991 cd        ghalf=0.0d0
7992         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7993         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7994         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7995         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7996         ghalf=0.5d0*ggg2(ll)
7997 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7998 cd        ghalf=0.0d0
7999         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
8000         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8001         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
8002         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8003       enddo
8004 cd      goto 1112
8005       do m=i+1,j-1
8006         do ll=1,3
8007 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8008           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8009         enddo
8010       enddo
8011       do m=k+1,l-1
8012         do ll=1,3
8013 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8014           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8015         enddo
8016       enddo
8017 1112  continue
8018       do m=i+2,j2
8019         do ll=1,3
8020           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8021         enddo
8022       enddo
8023       do m=k+2,l2
8024         do ll=1,3
8025           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8026         enddo
8027       enddo
8028 cd      do iii=1,nres-3
8029 cd        write (2,*) iii,g_corr6_loc(iii)
8030 cd      enddo
8031       endif
8032       eello6=ekont*eel6
8033 cd      write (2,*) 'ekont',ekont
8034 cd      write (iout,*) 'eello6',ekont*eel6
8035       return
8036       end
8037 c--------------------------------------------------------------------------
8038       double precision function eello6_graph1(i,j,k,l,imat,swap)
8039       implicit real*8 (a-h,o-z)
8040       include 'DIMENSIONS'
8041       include 'sizesclu.dat'
8042       include 'COMMON.IOUNITS'
8043       include 'COMMON.CHAIN'
8044       include 'COMMON.DERIV'
8045       include 'COMMON.INTERACT'
8046       include 'COMMON.CONTACTS'
8047       include 'COMMON.TORSION'
8048       include 'COMMON.VAR'
8049       include 'COMMON.GEO'
8050       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8051       logical swap
8052       logical lprn
8053       common /kutas/ lprn
8054 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8055 C                                                                              C
8056 C      Parallel       Antiparallel                                             C
8057 C                                                                              C
8058 C          o             o                                                     C
8059 C         /l\           /j\                                                    C
8060 C        /   \         /   \                                                   C
8061 C       /| o |         | o |\                                                  C
8062 C     \ j|/k\|  /   \  |/k\|l /                                                C
8063 C      \ /   \ /     \ /   \ /                                                 C
8064 C       o     o       o     o                                                  C
8065 C       i             i                                                        C
8066 C                                                                              C
8067 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8068       itk=itortyp(itype(k))
8069       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8070       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8071       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8072       call transpose2(EUgC(1,1,k),auxmat(1,1))
8073       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8074       vv1(1)=pizda1(1,1)-pizda1(2,2)
8075       vv1(2)=pizda1(1,2)+pizda1(2,1)
8076       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8077       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8078       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8079       s5=scalar2(vv(1),Dtobr2(1,i))
8080 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8081       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8082       if (.not. calc_grad) return
8083       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8084      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8085      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8086      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8087      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8088      & +scalar2(vv(1),Dtobr2der(1,i)))
8089       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8090       vv1(1)=pizda1(1,1)-pizda1(2,2)
8091       vv1(2)=pizda1(1,2)+pizda1(2,1)
8092       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8093       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8094       if (l.eq.j+1) then
8095         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8096      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8097      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8098      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8099      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8100       else
8101         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8102      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8103      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8104      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8105      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8106       endif
8107       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8108       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8109       vv1(1)=pizda1(1,1)-pizda1(2,2)
8110       vv1(2)=pizda1(1,2)+pizda1(2,1)
8111       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8112      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8113      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8114      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8115       do iii=1,2
8116         if (swap) then
8117           ind=3-iii
8118         else
8119           ind=iii
8120         endif
8121         do kkk=1,5
8122           do lll=1,3
8123             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8124             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8125             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8126             call transpose2(EUgC(1,1,k),auxmat(1,1))
8127             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8128      &        pizda1(1,1))
8129             vv1(1)=pizda1(1,1)-pizda1(2,2)
8130             vv1(2)=pizda1(1,2)+pizda1(2,1)
8131             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8132             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8133      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8134             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8135      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8136             s5=scalar2(vv(1),Dtobr2(1,i))
8137             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8138           enddo
8139         enddo
8140       enddo
8141       return
8142       end
8143 c----------------------------------------------------------------------------
8144       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8145       implicit real*8 (a-h,o-z)
8146       include 'DIMENSIONS'
8147       include 'sizesclu.dat'
8148       include 'COMMON.IOUNITS'
8149       include 'COMMON.CHAIN'
8150       include 'COMMON.DERIV'
8151       include 'COMMON.INTERACT'
8152       include 'COMMON.CONTACTS'
8153       include 'COMMON.TORSION'
8154       include 'COMMON.VAR'
8155       include 'COMMON.GEO'
8156       logical swap
8157       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8158      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8159       logical lprn
8160       common /kutas/ lprn
8161 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8162 C                                                                              C
8163 C      Parallel       Antiparallel                                             C
8164 C                                                                              C
8165 C          o             o                                                     C
8166 C     \   /l\           /j\   /                                                C
8167 C      \ /   \         /   \ /                                                 C
8168 C       o| o |         | o |o                                                  C
8169 C     \ j|/k\|      \  |/k\|l                                                  C
8170 C      \ /   \       \ /   \                                                   C
8171 C       o             o                                                        C
8172 C       i             i                                                        C
8173 C                                                                              C
8174 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8175 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8176 C AL 7/4/01 s1 would occur in the sixth-order moment,
8177 C           but not in a cluster cumulant
8178 #ifdef MOMENT
8179       s1=dip(1,jj,i)*dip(1,kk,k)
8180 #endif
8181       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8182       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8183       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8184       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8185       call transpose2(EUg(1,1,k),auxmat(1,1))
8186       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8187       vv(1)=pizda(1,1)-pizda(2,2)
8188       vv(2)=pizda(1,2)+pizda(2,1)
8189       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8190 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8191 #ifdef MOMENT
8192       eello6_graph2=-(s1+s2+s3+s4)
8193 #else
8194       eello6_graph2=-(s2+s3+s4)
8195 #endif
8196 c      eello6_graph2=-s3
8197       if (.not. calc_grad) return
8198 C Derivatives in gamma(i-1)
8199       if (i.gt.1) then
8200 #ifdef MOMENT
8201         s1=dipderg(1,jj,i)*dip(1,kk,k)
8202 #endif
8203         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8204         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8205         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8206         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8207 #ifdef MOMENT
8208         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8209 #else
8210         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8211 #endif
8212 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8213       endif
8214 C Derivatives in gamma(k-1)
8215 #ifdef MOMENT
8216       s1=dip(1,jj,i)*dipderg(1,kk,k)
8217 #endif
8218       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8219       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8220       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8221       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8222       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8223       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8224       vv(1)=pizda(1,1)-pizda(2,2)
8225       vv(2)=pizda(1,2)+pizda(2,1)
8226       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8227 #ifdef MOMENT
8228       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8229 #else
8230       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8231 #endif
8232 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8233 C Derivatives in gamma(j-1) or gamma(l-1)
8234       if (j.gt.1) then
8235 #ifdef MOMENT
8236         s1=dipderg(3,jj,i)*dip(1,kk,k)
8237 #endif
8238         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8239         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8240         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8241         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8242         vv(1)=pizda(1,1)-pizda(2,2)
8243         vv(2)=pizda(1,2)+pizda(2,1)
8244         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8245 #ifdef MOMENT
8246         if (swap) then
8247           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8248         else
8249           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8250         endif
8251 #endif
8252         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8253 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8254       endif
8255 C Derivatives in gamma(l-1) or gamma(j-1)
8256       if (l.gt.1) then
8257 #ifdef MOMENT
8258         s1=dip(1,jj,i)*dipderg(3,kk,k)
8259 #endif
8260         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8261         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8262         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8263         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8264         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8265         vv(1)=pizda(1,1)-pizda(2,2)
8266         vv(2)=pizda(1,2)+pizda(2,1)
8267         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8268 #ifdef MOMENT
8269         if (swap) then
8270           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8271         else
8272           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8273         endif
8274 #endif
8275         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8276 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8277       endif
8278 C Cartesian derivatives.
8279       if (lprn) then
8280         write (2,*) 'In eello6_graph2'
8281         do iii=1,2
8282           write (2,*) 'iii=',iii
8283           do kkk=1,5
8284             write (2,*) 'kkk=',kkk
8285             do jjj=1,2
8286               write (2,'(3(2f10.5),5x)')
8287      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8288             enddo
8289           enddo
8290         enddo
8291       endif
8292       do iii=1,2
8293         do kkk=1,5
8294           do lll=1,3
8295 #ifdef MOMENT
8296             if (iii.eq.1) then
8297               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8298             else
8299               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8300             endif
8301 #endif
8302             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8303      &        auxvec(1))
8304             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8305             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8306      &        auxvec(1))
8307             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8308             call transpose2(EUg(1,1,k),auxmat(1,1))
8309             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8310      &        pizda(1,1))
8311             vv(1)=pizda(1,1)-pizda(2,2)
8312             vv(2)=pizda(1,2)+pizda(2,1)
8313             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8314 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8315 #ifdef MOMENT
8316             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8317 #else
8318             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8319 #endif
8320             if (swap) then
8321               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8322             else
8323               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8324             endif
8325           enddo
8326         enddo
8327       enddo
8328       return
8329       end
8330 c----------------------------------------------------------------------------
8331       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8332       implicit real*8 (a-h,o-z)
8333       include 'DIMENSIONS'
8334       include 'sizesclu.dat'
8335       include 'COMMON.IOUNITS'
8336       include 'COMMON.CHAIN'
8337       include 'COMMON.DERIV'
8338       include 'COMMON.INTERACT'
8339       include 'COMMON.CONTACTS'
8340       include 'COMMON.TORSION'
8341       include 'COMMON.VAR'
8342       include 'COMMON.GEO'
8343       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8344       logical swap
8345 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8346 C                                                                              C
8347 C      Parallel       Antiparallel                                             C
8348 C                                                                              C
8349 C          o             o                                                     C
8350 C         /l\   /   \   /j\                                                    C
8351 C        /   \ /     \ /   \                                                   C
8352 C       /| o |o       o| o |\                                                  C
8353 C       j|/k\|  /      |/k\|l /                                                C
8354 C        /   \ /       /   \ /                                                 C
8355 C       /     o       /     o                                                  C
8356 C       i             i                                                        C
8357 C                                                                              C
8358 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8359 C
8360 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8361 C           energy moment and not to the cluster cumulant.
8362       iti=itortyp(itype(i))
8363 c      if (j.lt.nres-1) then
8364       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
8365         itj1=itortyp(itype(j+1))
8366       else
8367         itj1=ntortyp+1
8368       endif
8369       itk=itortyp(itype(k))
8370       itk1=itortyp(itype(k+1))
8371 c      if (l.lt.nres-1) then
8372       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
8373         itl1=itortyp(itype(l+1))
8374       else
8375         itl1=ntortyp+1
8376       endif
8377 #ifdef MOMENT
8378       s1=dip(4,jj,i)*dip(4,kk,k)
8379 #endif
8380       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8381       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8382       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8383       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8384       call transpose2(EE(1,1,itk),auxmat(1,1))
8385       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8386       vv(1)=pizda(1,1)+pizda(2,2)
8387       vv(2)=pizda(2,1)-pizda(1,2)
8388       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8389 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8390 #ifdef MOMENT
8391       eello6_graph3=-(s1+s2+s3+s4)
8392 #else
8393       eello6_graph3=-(s2+s3+s4)
8394 #endif
8395 c      eello6_graph3=-s4
8396       if (.not. calc_grad) return
8397 C Derivatives in gamma(k-1)
8398       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8399       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8400       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8401       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8402 C Derivatives in gamma(l-1)
8403       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8404       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8405       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8406       vv(1)=pizda(1,1)+pizda(2,2)
8407       vv(2)=pizda(2,1)-pizda(1,2)
8408       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8409       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8410 C Cartesian derivatives.
8411       do iii=1,2
8412         do kkk=1,5
8413           do lll=1,3
8414 #ifdef MOMENT
8415             if (iii.eq.1) then
8416               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8417             else
8418               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8419             endif
8420 #endif
8421             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8422      &        auxvec(1))
8423             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8424             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8425      &        auxvec(1))
8426             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8427             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8428      &        pizda(1,1))
8429             vv(1)=pizda(1,1)+pizda(2,2)
8430             vv(2)=pizda(2,1)-pizda(1,2)
8431             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8432 #ifdef MOMENT
8433             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8434 #else
8435             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8436 #endif
8437             if (swap) then
8438               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8439             else
8440               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8441             endif
8442 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8443           enddo
8444         enddo
8445       enddo
8446       return
8447       end
8448 c----------------------------------------------------------------------------
8449       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8450       implicit real*8 (a-h,o-z)
8451       include 'DIMENSIONS'
8452       include 'sizesclu.dat'
8453       include 'COMMON.IOUNITS'
8454       include 'COMMON.CHAIN'
8455       include 'COMMON.DERIV'
8456       include 'COMMON.INTERACT'
8457       include 'COMMON.CONTACTS'
8458       include 'COMMON.TORSION'
8459       include 'COMMON.VAR'
8460       include 'COMMON.GEO'
8461       include 'COMMON.FFIELD'
8462       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8463      & auxvec1(2),auxmat1(2,2)
8464       logical swap
8465 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8466 C                                                                              C
8467 C      Parallel       Antiparallel                                             C
8468 C                                                                              C
8469 C          o             o                                                     C
8470 C         /l\   /   \   /j\                                                    C
8471 C        /   \ /     \ /   \                                                   C
8472 C       /| o |o       o| o |\                                                  C
8473 C     \ j|/k\|      \  |/k\|l                                                  C
8474 C      \ /   \       \ /   \                                                   C
8475 C       o     \       o     \                                                  C
8476 C       i             i                                                        C
8477 C                                                                              C
8478 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8479 C
8480 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8481 C           energy moment and not to the cluster cumulant.
8482 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8483       iti=itortyp(itype(i))
8484       itj=itortyp(itype(j))
8485 c      if (j.lt.nres-1) then
8486       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
8487         itj1=itortyp(itype(j+1))
8488       else
8489         itj1=ntortyp+1
8490       endif
8491       itk=itortyp(itype(k))
8492 c      if (k.lt.nres-1) then
8493       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
8494         itk1=itortyp(itype(k+1))
8495       else
8496         itk1=ntortyp+1
8497       endif
8498       itl=itortyp(itype(l))
8499       if (l.lt.nres-1) then
8500         itl1=itortyp(itype(l+1))
8501       else
8502         itl1=ntortyp+1
8503       endif
8504 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8505 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8506 cd     & ' itl',itl,' itl1',itl1
8507 #ifdef MOMENT
8508       if (imat.eq.1) then
8509         s1=dip(3,jj,i)*dip(3,kk,k)
8510       else
8511         s1=dip(2,jj,j)*dip(2,kk,l)
8512       endif
8513 #endif
8514       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8515       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8516       if (j.eq.l+1) then
8517         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8518         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8519       else
8520         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8521         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8522       endif
8523       call transpose2(EUg(1,1,k),auxmat(1,1))
8524       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8525       vv(1)=pizda(1,1)-pizda(2,2)
8526       vv(2)=pizda(2,1)+pizda(1,2)
8527       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8528 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8529 #ifdef MOMENT
8530       eello6_graph4=-(s1+s2+s3+s4)
8531 #else
8532       eello6_graph4=-(s2+s3+s4)
8533 #endif
8534       if (.not. calc_grad) return
8535 C Derivatives in gamma(i-1)
8536       if (i.gt.1) then
8537 #ifdef MOMENT
8538         if (imat.eq.1) then
8539           s1=dipderg(2,jj,i)*dip(3,kk,k)
8540         else
8541           s1=dipderg(4,jj,j)*dip(2,kk,l)
8542         endif
8543 #endif
8544         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8545         if (j.eq.l+1) then
8546           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8547           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8548         else
8549           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8550           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8551         endif
8552         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8553         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8554 cd          write (2,*) 'turn6 derivatives'
8555 #ifdef MOMENT
8556           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8557 #else
8558           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8559 #endif
8560         else
8561 #ifdef MOMENT
8562           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8563 #else
8564           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8565 #endif
8566         endif
8567       endif
8568 C Derivatives in gamma(k-1)
8569 #ifdef MOMENT
8570       if (imat.eq.1) then
8571         s1=dip(3,jj,i)*dipderg(2,kk,k)
8572       else
8573         s1=dip(2,jj,j)*dipderg(4,kk,l)
8574       endif
8575 #endif
8576       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8577       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8578       if (j.eq.l+1) then
8579         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8580         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8581       else
8582         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8583         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8584       endif
8585       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8586       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8587       vv(1)=pizda(1,1)-pizda(2,2)
8588       vv(2)=pizda(2,1)+pizda(1,2)
8589       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8590       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8591 #ifdef MOMENT
8592         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8593 #else
8594         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8595 #endif
8596       else
8597 #ifdef MOMENT
8598         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8599 #else
8600         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8601 #endif
8602       endif
8603 C Derivatives in gamma(j-1) or gamma(l-1)
8604       if (l.eq.j+1 .and. l.gt.1) then
8605         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8606         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8607         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8608         vv(1)=pizda(1,1)-pizda(2,2)
8609         vv(2)=pizda(2,1)+pizda(1,2)
8610         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8611         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8612       else if (j.gt.1) then
8613         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8614         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8615         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8616         vv(1)=pizda(1,1)-pizda(2,2)
8617         vv(2)=pizda(2,1)+pizda(1,2)
8618         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8619         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8620           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8621         else
8622           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8623         endif
8624       endif
8625 C Cartesian derivatives.
8626       do iii=1,2
8627         do kkk=1,5
8628           do lll=1,3
8629 #ifdef MOMENT
8630             if (iii.eq.1) then
8631               if (imat.eq.1) then
8632                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8633               else
8634                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8635               endif
8636             else
8637               if (imat.eq.1) then
8638                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8639               else
8640                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8641               endif
8642             endif
8643 #endif
8644             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8645      &        auxvec(1))
8646             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8647             if (j.eq.l+1) then
8648               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8649      &          b1(1,itj1),auxvec(1))
8650               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8651             else
8652               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8653      &          b1(1,itl1),auxvec(1))
8654               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8655             endif
8656             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8657      &        pizda(1,1))
8658             vv(1)=pizda(1,1)-pizda(2,2)
8659             vv(2)=pizda(2,1)+pizda(1,2)
8660             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8661             if (swap) then
8662               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8663 #ifdef MOMENT
8664                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8665      &             -(s1+s2+s4)
8666 #else
8667                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8668      &             -(s2+s4)
8669 #endif
8670                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8671               else
8672 #ifdef MOMENT
8673                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8674 #else
8675                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8676 #endif
8677                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8678               endif
8679             else
8680 #ifdef MOMENT
8681               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8682 #else
8683               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8684 #endif
8685               if (l.eq.j+1) then
8686                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8687               else
8688                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8689               endif
8690             endif
8691           enddo
8692         enddo
8693       enddo
8694       return
8695       end
8696 c----------------------------------------------------------------------------
8697       double precision function eello_turn6(i,jj,kk)
8698       implicit real*8 (a-h,o-z)
8699       include 'DIMENSIONS'
8700       include 'sizesclu.dat'
8701       include 'COMMON.IOUNITS'
8702       include 'COMMON.CHAIN'
8703       include 'COMMON.DERIV'
8704       include 'COMMON.INTERACT'
8705       include 'COMMON.CONTACTS'
8706       include 'COMMON.TORSION'
8707       include 'COMMON.VAR'
8708       include 'COMMON.GEO'
8709       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8710      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8711      &  ggg1(3),ggg2(3)
8712       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8713      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8714 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8715 C           the respective energy moment and not to the cluster cumulant.
8716       eello_turn6=0.0d0
8717       j=i+4
8718       k=i+1
8719       l=i+3
8720       iti=itortyp(itype(i))
8721       itk=itortyp(itype(k))
8722       itk1=itortyp(itype(k+1))
8723       itl=itortyp(itype(l))
8724       itj=itortyp(itype(j))
8725 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8726 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8727 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8728 cd        eello6=0.0d0
8729 cd        return
8730 cd      endif
8731 cd      write (iout,*)
8732 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8733 cd     &   ' and',k,l
8734 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8735       do iii=1,2
8736         do kkk=1,5
8737           do lll=1,3
8738             derx_turn(lll,kkk,iii)=0.0d0
8739           enddo
8740         enddo
8741       enddo
8742 cd      eij=1.0d0
8743 cd      ekl=1.0d0
8744 cd      ekont=1.0d0
8745       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8746 cd      eello6_5=0.0d0
8747 cd      write (2,*) 'eello6_5',eello6_5
8748 #ifdef MOMENT
8749       call transpose2(AEA(1,1,1),auxmat(1,1))
8750       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8751       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8752       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8753 #else
8754       s1 = 0.0d0
8755 #endif
8756       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8757       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8758       s2 = scalar2(b1(1,itk),vtemp1(1))
8759 #ifdef MOMENT
8760       call transpose2(AEA(1,1,2),atemp(1,1))
8761       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8762       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8763       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8764 #else
8765       s8=0.0d0
8766 #endif
8767       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8768       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8769       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8770 #ifdef MOMENT
8771       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8772       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8773       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8774       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8775       ss13 = scalar2(b1(1,itk),vtemp4(1))
8776       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8777 #else
8778       s13=0.0d0
8779 #endif
8780 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8781 c      s1=0.0d0
8782 c      s2=0.0d0
8783 c      s8=0.0d0
8784 c      s12=0.0d0
8785 c      s13=0.0d0
8786       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8787       if (calc_grad) then
8788 C Derivatives in gamma(i+2)
8789 #ifdef MOMENT
8790       call transpose2(AEA(1,1,1),auxmatd(1,1))
8791       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8792       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8793       call transpose2(AEAderg(1,1,2),atempd(1,1))
8794       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8795       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8796 #else
8797       s8d=0.0d0
8798 #endif
8799       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8800       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8801       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8802 c      s1d=0.0d0
8803 c      s2d=0.0d0
8804 c      s8d=0.0d0
8805 c      s12d=0.0d0
8806 c      s13d=0.0d0
8807       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8808 C Derivatives in gamma(i+3)
8809 #ifdef MOMENT
8810       call transpose2(AEA(1,1,1),auxmatd(1,1))
8811       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8812       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8813       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8814 #else
8815       s1d=0.0d0
8816 #endif
8817       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8818       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8819       s2d = scalar2(b1(1,itk),vtemp1d(1))
8820 #ifdef MOMENT
8821       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8822       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8823 #endif
8824       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8825 #ifdef MOMENT
8826       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8827       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8828       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8829 #else
8830       s13d=0.0d0
8831 #endif
8832 c      s1d=0.0d0
8833 c      s2d=0.0d0
8834 c      s8d=0.0d0
8835 c      s12d=0.0d0
8836 c      s13d=0.0d0
8837 #ifdef MOMENT
8838       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8839      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8840 #else
8841       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8842      &               -0.5d0*ekont*(s2d+s12d)
8843 #endif
8844 C Derivatives in gamma(i+4)
8845       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8846       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8847       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8848 #ifdef MOMENT
8849       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8850       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8851       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8852 #else
8853       s13d = 0.0d0
8854 #endif
8855 c      s1d=0.0d0
8856 c      s2d=0.0d0
8857 c      s8d=0.0d0
8858 C      s12d=0.0d0
8859 c      s13d=0.0d0
8860 #ifdef MOMENT
8861       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8862 #else
8863       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8864 #endif
8865 C Derivatives in gamma(i+5)
8866 #ifdef MOMENT
8867       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8868       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8869       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8870 #else
8871       s1d = 0.0d0
8872 #endif
8873       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8874       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8875       s2d = scalar2(b1(1,itk),vtemp1d(1))
8876 #ifdef MOMENT
8877       call transpose2(AEA(1,1,2),atempd(1,1))
8878       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8879       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8880 #else
8881       s8d = 0.0d0
8882 #endif
8883       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8884       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8885 #ifdef MOMENT
8886       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8887       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8888       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8889 #else
8890       s13d = 0.0d0
8891 #endif
8892 c      s1d=0.0d0
8893 c      s2d=0.0d0
8894 c      s8d=0.0d0
8895 c      s12d=0.0d0
8896 c      s13d=0.0d0
8897 #ifdef MOMENT
8898       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8899      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8900 #else
8901       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8902      &               -0.5d0*ekont*(s2d+s12d)
8903 #endif
8904 C Cartesian derivatives
8905       do iii=1,2
8906         do kkk=1,5
8907           do lll=1,3
8908 #ifdef MOMENT
8909             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8910             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8911             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8912 #else
8913             s1d = 0.0d0
8914 #endif
8915             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8916             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8917      &          vtemp1d(1))
8918             s2d = scalar2(b1(1,itk),vtemp1d(1))
8919 #ifdef MOMENT
8920             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8921             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8922             s8d = -(atempd(1,1)+atempd(2,2))*
8923      &           scalar2(cc(1,1,itl),vtemp2(1))
8924 #else
8925             s8d = 0.0d0
8926 #endif
8927             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8928      &           auxmatd(1,1))
8929             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8930             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8931 c      s1d=0.0d0
8932 c      s2d=0.0d0
8933 c      s8d=0.0d0
8934 c      s12d=0.0d0
8935 c      s13d=0.0d0
8936 #ifdef MOMENT
8937             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8938      &        - 0.5d0*(s1d+s2d)
8939 #else
8940             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8941      &        - 0.5d0*s2d
8942 #endif
8943 #ifdef MOMENT
8944             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8945      &        - 0.5d0*(s8d+s12d)
8946 #else
8947             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8948      &        - 0.5d0*s12d
8949 #endif
8950           enddo
8951         enddo
8952       enddo
8953 #ifdef MOMENT
8954       do kkk=1,5
8955         do lll=1,3
8956           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8957      &      achuj_tempd(1,1))
8958           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8959           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8960           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8961           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8962           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8963      &      vtemp4d(1))
8964           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8965           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8966           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8967         enddo
8968       enddo
8969 #endif
8970 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8971 cd     &  16*eel_turn6_num
8972 cd      goto 1112
8973       if (j.lt.nres-1) then
8974         j1=j+1
8975         j2=j-1
8976       else
8977         j1=j-1
8978         j2=j-2
8979       endif
8980       if (l.lt.nres-1) then
8981         l1=l+1
8982         l2=l-1
8983       else
8984         l1=l-1
8985         l2=l-2
8986       endif
8987       do ll=1,3
8988         ggg1(ll)=eel_turn6*g_contij(ll,1)
8989         ggg2(ll)=eel_turn6*g_contij(ll,2)
8990         ghalf=0.5d0*ggg1(ll)
8991 cd        ghalf=0.0d0
8992         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8993      &    +ekont*derx_turn(ll,2,1)
8994         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8995         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8996      &    +ekont*derx_turn(ll,4,1)
8997         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8998         ghalf=0.5d0*ggg2(ll)
8999 cd        ghalf=0.0d0
9000         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
9001      &    +ekont*derx_turn(ll,2,2)
9002         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9003         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
9004      &    +ekont*derx_turn(ll,4,2)
9005         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9006       enddo
9007 cd      goto 1112
9008       do m=i+1,j-1
9009         do ll=1,3
9010           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9011         enddo
9012       enddo
9013       do m=k+1,l-1
9014         do ll=1,3
9015           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9016         enddo
9017       enddo
9018 1112  continue
9019       do m=i+2,j2
9020         do ll=1,3
9021           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9022         enddo
9023       enddo
9024       do m=k+2,l2
9025         do ll=1,3
9026           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9027         enddo
9028       enddo
9029 cd      do iii=1,nres-3
9030 cd        write (2,*) iii,g_corr6_loc(iii)
9031 cd      enddo
9032       endif
9033       eello_turn6=ekont*eel_turn6
9034 cd      write (2,*) 'ekont',ekont
9035 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9036       return
9037       end
9038 crc-------------------------------------------------
9039       SUBROUTINE MATVEC2(A1,V1,V2)
9040       implicit real*8 (a-h,o-z)
9041       include 'DIMENSIONS'
9042       DIMENSION A1(2,2),V1(2),V2(2)
9043 c      DO 1 I=1,2
9044 c        VI=0.0
9045 c        DO 3 K=1,2
9046 c    3     VI=VI+A1(I,K)*V1(K)
9047 c        Vaux(I)=VI
9048 c    1 CONTINUE
9049
9050       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9051       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9052
9053       v2(1)=vaux1
9054       v2(2)=vaux2
9055       END
9056 C---------------------------------------
9057       SUBROUTINE MATMAT2(A1,A2,A3)
9058       implicit real*8 (a-h,o-z)
9059       include 'DIMENSIONS'
9060       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9061 c      DIMENSION AI3(2,2)
9062 c        DO  J=1,2
9063 c          A3IJ=0.0
9064 c          DO K=1,2
9065 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9066 c          enddo
9067 c          A3(I,J)=A3IJ
9068 c       enddo
9069 c      enddo
9070
9071       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9072       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9073       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9074       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9075
9076       A3(1,1)=AI3_11
9077       A3(2,1)=AI3_21
9078       A3(1,2)=AI3_12
9079       A3(2,2)=AI3_22
9080       END
9081
9082 c-------------------------------------------------------------------------
9083       double precision function scalar2(u,v)
9084       implicit none
9085       double precision u(2),v(2)
9086       double precision sc
9087       integer i
9088       scalar2=u(1)*v(1)+u(2)*v(2)
9089       return
9090       end
9091
9092 C-----------------------------------------------------------------------------
9093
9094       subroutine transpose2(a,at)
9095       implicit none
9096       double precision a(2,2),at(2,2)
9097       at(1,1)=a(1,1)
9098       at(1,2)=a(2,1)
9099       at(2,1)=a(1,2)
9100       at(2,2)=a(2,2)
9101       return
9102       end
9103 c--------------------------------------------------------------------------
9104       subroutine transpose(n,a,at)
9105       implicit none
9106       integer n,i,j
9107       double precision a(n,n),at(n,n)
9108       do i=1,n
9109         do j=1,n
9110           at(j,i)=a(i,j)
9111         enddo
9112       enddo
9113       return
9114       end
9115 C---------------------------------------------------------------------------
9116       subroutine prodmat3(a1,a2,kk,transp,prod)
9117       implicit none
9118       integer i,j
9119       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9120       logical transp
9121 crc      double precision auxmat(2,2),prod_(2,2)
9122
9123       if (transp) then
9124 crc        call transpose2(kk(1,1),auxmat(1,1))
9125 crc        call matmat2(a1(1,1),auxmat(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(1,2))*a2(1,1)
9129      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9130            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9131      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9132            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9133      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9134            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9135      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9136
9137       else
9138 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9139 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9140
9141            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9142      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9143            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9144      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9145            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9146      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9147            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9148      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9149
9150       endif
9151 c      call transpose2(a2(1,1),a2t(1,1))
9152
9153 crc      print *,transp
9154 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9155 crc      print *,((prod(i,j),i=1,2),j=1,2)
9156
9157       return
9158       end
9159 C-----------------------------------------------------------------------------
9160       double precision function scalar(u,v)
9161       implicit none
9162       double precision u(3),v(3)
9163       double precision sc
9164       integer i
9165       sc=0.0d0
9166       do i=1,3
9167         sc=sc+u(i)*v(i)
9168       enddo
9169       scalar=sc
9170       return
9171       end
9172 C-----------------------------------------------------------------------
9173       double precision function sscale(r)
9174       double precision r,gamm
9175       include "COMMON.SPLITELE"
9176       if(r.lt.r_cut-rlamb) then
9177         sscale=1.0d0
9178       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9179         gamm=(r-(r_cut-rlamb))/rlamb
9180         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9181       else
9182         sscale=0d0
9183       endif
9184       return
9185       end
9186 C-----------------------------------------------------------------------
9187 C-----------------------------------------------------------------------
9188       double precision function sscagrad(r)
9189       double precision r,gamm
9190       include "COMMON.SPLITELE"
9191       if(r.lt.r_cut-rlamb) then
9192         sscagrad=0.0d0
9193       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9194         gamm=(r-(r_cut-rlamb))/rlamb
9195         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9196       else
9197         sscagrad=0.0d0
9198       endif
9199       return
9200       end
9201 C-----------------------------------------------------------------------
9202 C first for shielding is setting of function of side-chains
9203        subroutine set_shield_fac2
9204       implicit real*8 (a-h,o-z)
9205       include 'DIMENSIONS'
9206       include 'COMMON.CHAIN'
9207       include 'COMMON.DERIV'
9208       include 'COMMON.IOUNITS'
9209       include 'COMMON.SHIELD'
9210       include 'COMMON.INTERACT'
9211 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9212       double precision div77_81/0.974996043d0/,
9213      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9214
9215 C the vector between center of side_chain and peptide group
9216        double precision pep_side(3),long,side_calf(3),
9217      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9218      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9219 C the line belowe needs to be changed for FGPROC>1
9220       do i=1,nres-1
9221       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9222       ishield_list(i)=0
9223 Cif there two consequtive dummy atoms there is no peptide group between them
9224 C the line below has to be changed for FGPROC>1
9225       VolumeTotal=0.0
9226       do k=1,nres
9227        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9228        dist_pep_side=0.0
9229        dist_side_calf=0.0
9230        do j=1,3
9231 C first lets set vector conecting the ithe side-chain with kth side-chain
9232       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9233 C      pep_side(j)=2.0d0
9234 C and vector conecting the side-chain with its proper calfa
9235       side_calf(j)=c(j,k+nres)-c(j,k)
9236 C      side_calf(j)=2.0d0
9237       pept_group(j)=c(j,i)-c(j,i+1)
9238 C lets have their lenght
9239       dist_pep_side=pep_side(j)**2+dist_pep_side
9240       dist_side_calf=dist_side_calf+side_calf(j)**2
9241       dist_pept_group=dist_pept_group+pept_group(j)**2
9242       enddo
9243        dist_pep_side=dsqrt(dist_pep_side)
9244        dist_pept_group=dsqrt(dist_pept_group)
9245        dist_side_calf=dsqrt(dist_side_calf)
9246       do j=1,3
9247         pep_side_norm(j)=pep_side(j)/dist_pep_side
9248         side_calf_norm(j)=dist_side_calf
9249       enddo
9250 C now sscale fraction
9251        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9252 C       print *,buff_shield,"buff"
9253 C now sscale
9254         if (sh_frac_dist.le.0.0) cycle
9255 C If we reach here it means that this side chain reaches the shielding sphere
9256 C Lets add him to the list for gradient
9257         ishield_list(i)=ishield_list(i)+1
9258 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9259 C this list is essential otherwise problem would be O3
9260         shield_list(ishield_list(i),i)=k
9261 C Lets have the sscale value
9262         if (sh_frac_dist.gt.1.0) then
9263          scale_fac_dist=1.0d0
9264          do j=1,3
9265          sh_frac_dist_grad(j)=0.0d0
9266          enddo
9267         else
9268          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9269      &                   *(2.0d0*sh_frac_dist-3.0d0)
9270          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9271      &                  /dist_pep_side/buff_shield*0.5d0
9272 C remember for the final gradient multiply sh_frac_dist_grad(j)
9273 C for side_chain by factor -2 !
9274          do j=1,3
9275          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9276 C         sh_frac_dist_grad(j)=0.0d0
9277 C         scale_fac_dist=1.0d0
9278 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9279 C     &                    sh_frac_dist_grad(j)
9280          enddo
9281         endif
9282 C this is what is now we have the distance scaling now volume...
9283       short=short_r_sidechain(itype(k))
9284       long=long_r_sidechain(itype(k))
9285       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9286       sinthet=short/dist_pep_side*costhet
9287 C now costhet_grad
9288 C       costhet=0.6d0
9289 C       sinthet=0.8
9290        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9291 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9292 C     &             -short/dist_pep_side**2/costhet)
9293 C       costhet_fac=0.0d0
9294        do j=1,3
9295          costhet_grad(j)=costhet_fac*pep_side(j)
9296        enddo
9297 C remember for the final gradient multiply costhet_grad(j)
9298 C for side_chain by factor -2 !
9299 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9300 C pep_side0pept_group is vector multiplication
9301       pep_side0pept_group=0.0d0
9302       do j=1,3
9303       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9304       enddo
9305       cosalfa=(pep_side0pept_group/
9306      & (dist_pep_side*dist_side_calf))
9307       fac_alfa_sin=1.0d0-cosalfa**2
9308       fac_alfa_sin=dsqrt(fac_alfa_sin)
9309       rkprim=fac_alfa_sin*(long-short)+short
9310 C      rkprim=short
9311
9312 C now costhet_grad
9313        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9314 C       cosphi=0.6
9315        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9316        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9317      &      dist_pep_side**2)
9318 C       sinphi=0.8
9319        do j=1,3
9320          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9321      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9322      &*(long-short)/fac_alfa_sin*cosalfa/
9323      &((dist_pep_side*dist_side_calf))*
9324      &((side_calf(j))-cosalfa*
9325      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9326 C       cosphi_grad_long(j)=0.0d0
9327         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9328      &*(long-short)/fac_alfa_sin*cosalfa
9329      &/((dist_pep_side*dist_side_calf))*
9330      &(pep_side(j)-
9331      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9332 C       cosphi_grad_loc(j)=0.0d0
9333        enddo
9334 C      print *,sinphi,sinthet
9335       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9336      &                    /VSolvSphere_div
9337 C     &                    *wshield
9338 C now the gradient...
9339       do j=1,3
9340       grad_shield(j,i)=grad_shield(j,i)
9341 C gradient po skalowaniu
9342      &                +(sh_frac_dist_grad(j)*VofOverlap
9343 C  gradient po costhet
9344      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9345      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9346      &       sinphi/sinthet*costhet*costhet_grad(j)
9347      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9348      & )*wshield
9349 C grad_shield_side is Cbeta sidechain gradient
9350       grad_shield_side(j,ishield_list(i),i)=
9351      &        (sh_frac_dist_grad(j)*(-2.0d0)
9352      &        *VofOverlap
9353      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9354      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9355      &       sinphi/sinthet*costhet*costhet_grad(j)
9356      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9357      &       )*wshield
9358
9359        grad_shield_loc(j,ishield_list(i),i)=
9360      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9361      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9362      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9363      &        ))
9364      &        *wshield
9365       enddo
9366       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9367       enddo
9368       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9369 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9370       enddo
9371       return
9372       end
9373 C first for shielding is setting of function of side-chains
9374        subroutine set_shield_fac
9375       implicit real*8 (a-h,o-z)
9376       include 'DIMENSIONS'
9377       include 'COMMON.CHAIN'
9378       include 'COMMON.DERIV'
9379       include 'COMMON.IOUNITS'
9380       include 'COMMON.SHIELD'
9381       include 'COMMON.INTERACT'
9382 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9383       double precision div77_81/0.974996043d0/,
9384      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9385
9386 C the vector between center of side_chain and peptide group
9387        double precision pep_side(3),long,side_calf(3),
9388      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9389      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9390 C the line belowe needs to be changed for FGPROC>1
9391       do i=1,nres-1
9392       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9393       ishield_list(i)=0
9394 Cif there two consequtive dummy atoms there is no peptide group between them
9395 C the line below has to be changed for FGPROC>1
9396       VolumeTotal=0.0
9397       do k=1,nres
9398        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9399        dist_pep_side=0.0
9400        dist_side_calf=0.0
9401        do j=1,3
9402 C first lets set vector conecting the ithe side-chain with kth side-chain
9403       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9404 C      pep_side(j)=2.0d0
9405 C and vector conecting the side-chain with its proper calfa
9406       side_calf(j)=c(j,k+nres)-c(j,k)
9407 C      side_calf(j)=2.0d0
9408       pept_group(j)=c(j,i)-c(j,i+1)
9409 C lets have their lenght
9410       dist_pep_side=pep_side(j)**2+dist_pep_side
9411       dist_side_calf=dist_side_calf+side_calf(j)**2
9412       dist_pept_group=dist_pept_group+pept_group(j)**2
9413       enddo
9414        dist_pep_side=dsqrt(dist_pep_side)
9415        dist_pept_group=dsqrt(dist_pept_group)
9416        dist_side_calf=dsqrt(dist_side_calf)
9417       do j=1,3
9418         pep_side_norm(j)=pep_side(j)/dist_pep_side
9419         side_calf_norm(j)=dist_side_calf
9420       enddo
9421 C now sscale fraction
9422        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9423 C       print *,buff_shield,"buff"
9424 C now sscale
9425         if (sh_frac_dist.le.0.0) cycle
9426 C If we reach here it means that this side chain reaches the shielding sphere
9427 C Lets add him to the list for gradient
9428         ishield_list(i)=ishield_list(i)+1
9429 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9430 C this list is essential otherwise problem would be O3
9431         shield_list(ishield_list(i),i)=k
9432 C Lets have the sscale value
9433         if (sh_frac_dist.gt.1.0) then
9434          scale_fac_dist=1.0d0
9435          do j=1,3
9436          sh_frac_dist_grad(j)=0.0d0
9437          enddo
9438         else
9439          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9440      &                   *(2.0*sh_frac_dist-3.0d0)
9441          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9442      &                  /dist_pep_side/buff_shield*0.5
9443 C remember for the final gradient multiply sh_frac_dist_grad(j)
9444 C for side_chain by factor -2 !
9445          do j=1,3
9446          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9447 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9448 C     &                    sh_frac_dist_grad(j)
9449          enddo
9450         endif
9451 C        if ((i.eq.3).and.(k.eq.2)) then
9452 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9453 C     & ,"TU"
9454 C        endif
9455
9456 C this is what is now we have the distance scaling now volume...
9457       short=short_r_sidechain(itype(k))
9458       long=long_r_sidechain(itype(k))
9459       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9460 C now costhet_grad
9461 C       costhet=0.0d0
9462        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9463 C       costhet_fac=0.0d0
9464        do j=1,3
9465          costhet_grad(j)=costhet_fac*pep_side(j)
9466        enddo
9467 C remember for the final gradient multiply costhet_grad(j)
9468 C for side_chain by factor -2 !
9469 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9470 C pep_side0pept_group is vector multiplication
9471       pep_side0pept_group=0.0
9472       do j=1,3
9473       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9474       enddo
9475       cosalfa=(pep_side0pept_group/
9476      & (dist_pep_side*dist_side_calf))
9477       fac_alfa_sin=1.0-cosalfa**2
9478       fac_alfa_sin=dsqrt(fac_alfa_sin)
9479       rkprim=fac_alfa_sin*(long-short)+short
9480 C now costhet_grad
9481        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9482        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9483
9484        do j=1,3
9485          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9486      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9487      &*(long-short)/fac_alfa_sin*cosalfa/
9488      &((dist_pep_side*dist_side_calf))*
9489      &((side_calf(j))-cosalfa*
9490      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9491
9492         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9493      &*(long-short)/fac_alfa_sin*cosalfa
9494      &/((dist_pep_side*dist_side_calf))*
9495      &(pep_side(j)-
9496      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9497        enddo
9498
9499       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9500      &                    /VSolvSphere_div
9501      &                    *wshield
9502 C now the gradient...
9503 C grad_shield is gradient of Calfa for peptide groups
9504 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9505 C     &               costhet,cosphi
9506 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9507 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9508       do j=1,3
9509       grad_shield(j,i)=grad_shield(j,i)
9510 C gradient po skalowaniu
9511      &                +(sh_frac_dist_grad(j)
9512 C  gradient po costhet
9513      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9514      &-scale_fac_dist*(cosphi_grad_long(j))
9515      &/(1.0-cosphi) )*div77_81
9516      &*VofOverlap
9517 C grad_shield_side is Cbeta sidechain gradient
9518       grad_shield_side(j,ishield_list(i),i)=
9519      &        (sh_frac_dist_grad(j)*(-2.0d0)
9520      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9521      &       +scale_fac_dist*(cosphi_grad_long(j))
9522      &        *2.0d0/(1.0-cosphi))
9523      &        *div77_81*VofOverlap
9524
9525        grad_shield_loc(j,ishield_list(i),i)=
9526      &   scale_fac_dist*cosphi_grad_loc(j)
9527      &        *2.0d0/(1.0-cosphi)
9528      &        *div77_81*VofOverlap
9529       enddo
9530       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9531       enddo
9532       fac_shield(i)=VolumeTotal*div77_81+div4_81
9533 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9534       enddo
9535       return
9536       end
9537 C--------------------------------------------------------------------------
9538 C-----------------------------------------------------------------------
9539       double precision function sscalelip(r)
9540       double precision r,gamm
9541       include "COMMON.SPLITELE"
9542 C      if(r.lt.r_cut-rlamb) then
9543 C        sscale=1.0d0
9544 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9545 C        gamm=(r-(r_cut-rlamb))/rlamb
9546         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9547 C      else
9548 C        sscale=0d0
9549 C      endif
9550       return
9551       end
9552 C-----------------------------------------------------------------------
9553       double precision function sscagradlip(r)
9554       double precision r,gamm
9555       include "COMMON.SPLITELE"
9556 C     if(r.lt.r_cut-rlamb) then
9557 C        sscagrad=0.0d0
9558 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9559 C        gamm=(r-(r_cut-rlamb))/rlamb
9560         sscagradlip=r*(6*r-6.0d0)
9561 C      else
9562 C        sscagrad=0.0d0
9563 C      endif
9564       return
9565       end
9566 c----------------------------------------------------------------------------
9567       double precision function sscale2(r,r_cut,r0,rlamb)
9568       implicit none
9569       double precision r,gamm,r_cut,r0,rlamb,rr
9570       rr = dabs(r-r0)
9571 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9572 c      write (2,*) "rr",rr
9573       if(rr.lt.r_cut-rlamb) then
9574         sscale2=1.0d0
9575       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9576         gamm=(rr-(r_cut-rlamb))/rlamb
9577         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9578       else
9579         sscale2=0d0
9580       endif
9581       return
9582       end
9583 C-----------------------------------------------------------------------
9584       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9585       implicit none
9586       double precision r,gamm,r_cut,r0,rlamb,rr
9587       rr = dabs(r-r0)
9588       if(rr.lt.r_cut-rlamb) then
9589         sscalgrad2=0.0d0
9590       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9591         gamm=(rr-(r_cut-rlamb))/rlamb
9592         if (r.ge.r0) then
9593           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9594         else
9595           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9596         endif
9597       else
9598         sscalgrad2=0.0d0
9599       endif
9600       return
9601       end
9602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9603       subroutine Eliptransfer(eliptran)
9604       implicit real*8 (a-h,o-z)
9605       include 'DIMENSIONS'
9606       include 'COMMON.GEO'
9607       include 'COMMON.VAR'
9608       include 'COMMON.LOCAL'
9609       include 'COMMON.CHAIN'
9610       include 'COMMON.DERIV'
9611       include 'COMMON.INTERACT'
9612       include 'COMMON.IOUNITS'
9613       include 'COMMON.CALC'
9614       include 'COMMON.CONTROL'
9615       include 'COMMON.SPLITELE'
9616       include 'COMMON.SBRIDGE'
9617 C this is done by Adasko
9618 C      print *,"wchodze"
9619 C structure of box:
9620 C      water
9621 C--bordliptop-- buffore starts
9622 C--bufliptop--- here true lipid starts
9623 C      lipid
9624 C--buflipbot--- lipid ends buffore starts
9625 C--bordlipbot--buffore ends
9626       eliptran=0.0
9627       write(iout,*) "I am in?"
9628       do i=1,nres
9629 C       do i=1,1
9630         if (itype(i).eq.ntyp1) cycle
9631
9632         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9633         if (positi.le.0) positi=positi+boxzsize
9634 C        print *,i
9635 C first for peptide groups
9636 c for each residue check if it is in lipid or lipid water border area
9637        if ((positi.gt.bordlipbot)
9638      &.and.(positi.lt.bordliptop)) then
9639 C the energy transfer exist
9640         if (positi.lt.buflipbot) then
9641 C what fraction I am in
9642          fracinbuf=1.0d0-
9643      &        ((positi-bordlipbot)/lipbufthick)
9644 C lipbufthick is thickenes of lipid buffore
9645          sslip=sscalelip(fracinbuf)
9646          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9647          eliptran=eliptran+sslip*pepliptran
9648          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9649          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9650 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9651         elseif (positi.gt.bufliptop) then
9652          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9653          sslip=sscalelip(fracinbuf)
9654          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9655          eliptran=eliptran+sslip*pepliptran
9656          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9657          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9658 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9659 C          print *, "doing sscalefor top part"
9660 C         print *,i,sslip,fracinbuf,ssgradlip
9661         else
9662          eliptran=eliptran+pepliptran
9663 C         print *,"I am in true lipid"
9664         endif
9665 C       else
9666 C       eliptran=elpitran+0.0 ! I am in water
9667        endif
9668        enddo
9669 C       print *, "nic nie bylo w lipidzie?"
9670 C now multiply all by the peptide group transfer factor
9671 C       eliptran=eliptran*pepliptran
9672 C now the same for side chains
9673 CV       do i=1,1
9674        do i=1,nres
9675         if (itype(i).eq.ntyp1) cycle
9676         positi=(mod(c(3,i+nres),boxzsize))
9677         if (positi.le.0) positi=positi+boxzsize
9678 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9679 c for each residue check if it is in lipid or lipid water border area
9680 C       respos=mod(c(3,i+nres),boxzsize)
9681 C       print *,positi,bordlipbot,buflipbot
9682        if ((positi.gt.bordlipbot)
9683      & .and.(positi.lt.bordliptop)) then
9684 C the energy transfer exist
9685         if (positi.lt.buflipbot) then
9686          fracinbuf=1.0d0-
9687      &     ((positi-bordlipbot)/lipbufthick)
9688 C lipbufthick is thickenes of lipid buffore
9689          sslip=sscalelip(fracinbuf)
9690          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9691          eliptran=eliptran+sslip*liptranene(itype(i))
9692          gliptranx(3,i)=gliptranx(3,i)
9693      &+ssgradlip*liptranene(itype(i))
9694          gliptranc(3,i-1)= gliptranc(3,i-1)
9695      &+ssgradlip*liptranene(itype(i))
9696 C         print *,"doing sccale for lower part"
9697         elseif (positi.gt.bufliptop) then
9698          fracinbuf=1.0d0-
9699      &((bordliptop-positi)/lipbufthick)
9700          sslip=sscalelip(fracinbuf)
9701          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9702          eliptran=eliptran+sslip*liptranene(itype(i))
9703          gliptranx(3,i)=gliptranx(3,i)
9704      &+ssgradlip*liptranene(itype(i))
9705          gliptranc(3,i-1)= gliptranc(3,i-1)
9706      &+ssgradlip*liptranene(itype(i))
9707 C          print *, "doing sscalefor top part",sslip,fracinbuf
9708         else
9709          eliptran=eliptran+liptranene(itype(i))
9710 C         print *,"I am in true lipid"
9711         endif
9712         endif ! if in lipid or buffor
9713 C       else
9714 C       eliptran=elpitran+0.0 ! I am in water
9715        enddo
9716        return
9717        end
9718 c----------------------------------------------------------------------------
9719       subroutine e_saxs(Esaxs_constr)
9720       implicit none
9721       include 'DIMENSIONS'
9722 #ifdef MPI
9723       include "mpif.h"
9724       include "COMMON.SETUP"
9725       integer IERR
9726 #endif
9727       include 'COMMON.SBRIDGE'
9728       include 'COMMON.CHAIN'
9729       include 'COMMON.GEO'
9730       include 'COMMON.LOCAL'
9731       include 'COMMON.INTERACT'
9732       include 'COMMON.VAR'
9733       include 'COMMON.IOUNITS'
9734       include 'COMMON.DERIV'
9735       include 'COMMON.CONTROL'
9736       include 'COMMON.NAMES'
9737       include 'COMMON.FFIELD'
9738       include 'COMMON.LANGEVIN'
9739 c
9740       double precision Esaxs_constr
9741       integer i,iint,j,k,l
9742       double precision PgradC(maxSAXS,3,maxres),
9743      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
9744 #ifdef MPI
9745       double precision PgradC_(maxSAXS,3,maxres),
9746      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9747 #endif
9748       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9749      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9750      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9751      & auxX,auxX1,CACAgrad,Cnorm
9752       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9753       double precision dist
9754       external dist
9755 c  SAXS restraint penalty function
9756 #ifdef DEBUG
9757       write(iout,*) "------- SAXS penalty function start -------"
9758       write (iout,*) "nsaxs",nsaxs
9759       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9760       write (iout,*) "Psaxs"
9761       do i=1,nsaxs
9762         write (iout,'(i5,e15.5)') i, Psaxs(i)
9763       enddo
9764 #endif
9765       Esaxs_constr = 0.0d0
9766       do k=1,nsaxs
9767         Pcalc(k)=0.0d0
9768         do j=1,nres
9769           do l=1,3
9770             PgradC(k,l,j)=0.0d0
9771             PgradX(k,l,j)=0.0d0
9772           enddo
9773         enddo
9774       enddo
9775       do i=iatsc_s,iatsc_e
9776        if (itype(i).eq.ntyp1) cycle
9777        do iint=1,nint_gr(i)
9778          do j=istart(i,iint),iend(i,iint)
9779            if (itype(j).eq.ntyp1) cycle
9780 #ifdef ALLSAXS
9781            dijCACA=dist(i,j)
9782            dijCASC=dist(i,j+nres)
9783            dijSCCA=dist(i+nres,j)
9784            dijSCSC=dist(i+nres,j+nres)
9785            sigma2CACA=2.0d0/(pstok**2)
9786            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9787            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9788            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9789            do k=1,nsaxs
9790              dk = distsaxs(k)
9791              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9792              if (itype(j).ne.10) then
9793              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9794              else
9795              endif
9796              expCASC = 0.0d0
9797              if (itype(i).ne.10) then
9798              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9799              else
9800              expSCCA = 0.0d0
9801              endif
9802              if (itype(i).ne.10 .and. itype(j).ne.10) then
9803              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9804              else
9805              expSCSC = 0.0d0
9806              endif
9807              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9808 #ifdef DEBUG
9809              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9810 #endif
9811              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9812              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9813              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9814              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9815              do l=1,3
9816 c CA CA
9817                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9818                PgradC(k,l,i) = PgradC(k,l,i)-aux
9819                PgradC(k,l,j) = PgradC(k,l,j)+aux
9820 c CA SC
9821                if (itype(j).ne.10) then
9822                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9823                PgradC(k,l,i) = PgradC(k,l,i)-aux
9824                PgradC(k,l,j) = PgradC(k,l,j)+aux
9825                PgradX(k,l,j) = PgradX(k,l,j)+aux
9826                endif
9827 c SC CA
9828                if (itype(i).ne.10) then
9829                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9830                PgradX(k,l,i) = PgradX(k,l,i)-aux
9831                PgradC(k,l,i) = PgradC(k,l,i)-aux
9832                PgradC(k,l,j) = PgradC(k,l,j)+aux
9833                endif
9834 c SC SC
9835                if (itype(i).ne.10 .and. itype(j).ne.10) then
9836                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9837                PgradC(k,l,i) = PgradC(k,l,i)-aux
9838                PgradC(k,l,j) = PgradC(k,l,j)+aux
9839                PgradX(k,l,i) = PgradX(k,l,i)-aux
9840                PgradX(k,l,j) = PgradX(k,l,j)+aux
9841                endif
9842              enddo ! l
9843            enddo ! k
9844 #else
9845            dijCACA=dist(i,j)
9846            sigma2CACA=scal_rad**2*0.25d0/
9847      &        (restok(itype(j))**2+restok(itype(i))**2)
9848
9849            IF (saxs_cutoff.eq.0) THEN
9850            do k=1,nsaxs
9851              dk = distsaxs(k)
9852              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9853              Pcalc(k) = Pcalc(k)+expCACA
9854              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9855              do l=1,3
9856                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9857                PgradC(k,l,i) = PgradC(k,l,i)-aux
9858                PgradC(k,l,j) = PgradC(k,l,j)+aux
9859              enddo ! l
9860            enddo ! k
9861            ELSE
9862            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9863            do k=1,nsaxs
9864              dk = distsaxs(k)
9865 c             write (2,*) "ijk",i,j,k
9866              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9867              if (sss2.eq.0.0d0) cycle
9868              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9869              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9870              Pcalc(k) = Pcalc(k)+expCACA
9871 #ifdef DEBUG
9872              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9873 #endif
9874              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9875      &             ssgrad2*expCACA/sss2
9876              do l=1,3
9877 c CA CA
9878                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9879                PgradC(k,l,i) = PgradC(k,l,i)+aux
9880                PgradC(k,l,j) = PgradC(k,l,j)-aux
9881              enddo ! l
9882            enddo ! k
9883            ENDIF
9884 #endif
9885          enddo ! j
9886        enddo ! iint
9887       enddo ! i
9888 #ifdef MPI
9889       if (nfgtasks.gt.1) then
9890         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9891      &    MPI_SUM,king,FG_COMM,IERR)
9892         if (fg_rank.eq.king) then
9893           do k=1,nsaxs
9894             Pcalc(k) = Pcalc_(k)
9895           enddo
9896         endif
9897         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9898      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9899         if (fg_rank.eq.king) then
9900           do i=1,nres
9901             do l=1,3
9902               do k=1,nsaxs
9903                 PgradC(k,l,i) = PgradC_(k,l,i)
9904               enddo
9905             enddo
9906           enddo
9907         endif
9908 #ifdef ALLSAXS
9909         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9910      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9911         if (fg_rank.eq.king) then
9912           do i=1,nres
9913             do l=1,3
9914               do k=1,nsaxs
9915                 PgradX(k,l,i) = PgradX_(k,l,i)
9916               enddo
9917             enddo
9918           enddo
9919         endif
9920 #endif
9921       endif
9922 #endif
9923 #ifdef MPI
9924       if (fg_rank.eq.king) then
9925 #endif
9926       Cnorm = 0.0d0
9927       do k=1,nsaxs
9928         Cnorm = Cnorm + Pcalc(k)
9929       enddo
9930       Esaxs_constr = dlog(Cnorm)-wsaxs0
9931       do k=1,nsaxs
9932         if (Pcalc(k).gt.0.0d0)
9933      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9934 #ifdef DEBUG
9935         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9936 #endif
9937       enddo
9938 #ifdef DEBUG
9939       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9940 #endif
9941       do i=nnt,nct
9942         do l=1,3
9943           auxC=0.0d0
9944           auxC1=0.0d0
9945           auxX=0.0d0
9946           auxX1=0.d0
9947           do k=1,nsaxs
9948             if (Pcalc(k).gt.0)
9949      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9950             auxC1 = auxC1+PgradC(k,l,i)
9951 #ifdef ALLSAXS
9952             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9953             auxX1 = auxX1+PgradX(k,l,i)
9954 #endif
9955           enddo
9956           gsaxsC(l,i) = auxC - auxC1/Cnorm
9957 #ifdef ALLSAXS
9958           gsaxsX(l,i) = auxX - auxX1/Cnorm
9959 #endif
9960 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9961 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9962         enddo
9963       enddo
9964 #ifdef MPI
9965       endif
9966 #endif
9967       return
9968       end
9969 c----------------------------------------------------------------------------
9970       subroutine e_saxsC(Esaxs_constr)
9971       implicit none
9972       include 'DIMENSIONS'
9973 #ifdef MPI
9974       include "mpif.h"
9975       include "COMMON.SETUP"
9976       integer IERR
9977 #endif
9978       include 'COMMON.SBRIDGE'
9979       include 'COMMON.CHAIN'
9980       include 'COMMON.INTERACT'
9981       include 'COMMON.GEO'
9982       include 'COMMON.LOCAL'
9983       include 'COMMON.VAR'
9984       include 'COMMON.IOUNITS'
9985       include 'COMMON.DERIV'
9986       include 'COMMON.CONTROL'
9987       include 'COMMON.NAMES'
9988       include 'COMMON.FFIELD'
9989       include 'COMMON.LANGEVIN'
9990 c
9991       double precision Esaxs_constr
9992       integer i,iint,j,k,l
9993       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
9994 #ifdef MPI
9995       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
9996 #endif
9997       double precision dk,dijCASPH,dijSCSPH,
9998      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
9999      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
10000      & auxX,auxX1,Cnorm
10001 c  SAXS restraint penalty function
10002 #ifdef DEBUG
10003       write(iout,*) "------- SAXS penalty function start -------"
10004       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
10005      & " isaxs_end",isaxs_end
10006       write (iout,*) "nnt",nnt," ntc",nct
10007       do i=nnt,nct
10008         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
10009      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
10010       enddo
10011       do i=nnt,nct
10012         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
10013       enddo
10014 #endif
10015       Esaxs_constr = 0.0d0
10016       logPtot=0.0d0
10017       do j=isaxs_start,isaxs_end
10018         Pcalc=0.0d0
10019         do i=1,nres
10020           do l=1,3
10021             PgradC(l,i)=0.0d0
10022             PgradX(l,i)=0.0d0
10023           enddo
10024         enddo
10025         do i=nnt,nct
10026           dijCASPH=0.0d0
10027           dijSCSPH=0.0d0
10028           do l=1,3
10029             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
10030           enddo
10031           if (itype(i).ne.10) then
10032           do l=1,3
10033             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
10034           enddo
10035           endif
10036           sigma2CA=2.0d0/pstok**2
10037           sigma2SC=4.0d0/restok(itype(i))**2
10038           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
10039           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
10040           Pcalc = Pcalc+expCASPH+expSCSPH
10041 #ifdef DEBUG
10042           write(*,*) "processor i j Pcalc",
10043      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
10044 #endif
10045           CASPHgrad = sigma2CA*expCASPH
10046           SCSPHgrad = sigma2SC*expSCSPH
10047           do l=1,3
10048             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
10049             PgradX(l,i) = PgradX(l,i) + aux
10050             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
10051           enddo ! l
10052         enddo ! i
10053         do i=nnt,nct
10054           do l=1,3
10055             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
10056             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
10057           enddo
10058         enddo
10059         logPtot = logPtot - dlog(Pcalc)
10060 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
10061 c     &    " logPtot",logPtot
10062       enddo ! j
10063 #ifdef MPI
10064       if (nfgtasks.gt.1) then
10065 c        write (iout,*) "logPtot before reduction",logPtot
10066         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
10067      &    MPI_SUM,king,FG_COMM,IERR)
10068         logPtot = logPtot_
10069 c        write (iout,*) "logPtot after reduction",logPtot
10070         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
10071      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10072         if (fg_rank.eq.king) then
10073           do i=1,nres
10074             do l=1,3
10075               gsaxsC(l,i) = gsaxsC_(l,i)
10076             enddo
10077           enddo
10078         endif
10079         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
10080      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10081         if (fg_rank.eq.king) then
10082           do i=1,nres
10083             do l=1,3
10084               gsaxsX(l,i) = gsaxsX_(l,i)
10085             enddo
10086           enddo
10087         endif
10088       endif
10089 #endif
10090       Esaxs_constr = logPtot
10091       return
10092       end