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       write (iout,*) "ft(6)",fact(6),wliptran,eliptran
 125 #ifdef SPLITELE
 126       if (shield_mode.gt.0) then
 127       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 128      & +welec*fact(1)*ees
 129      & +fact(1)*wvdwpp*evdw1
 130      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 131      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 132      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 133      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 134      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 135      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 136      & +wliptran*eliptran
 137       else
 138       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 139      & +wvdwpp*evdw1
 140      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 141      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 142      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 143      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 144      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 145      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 146      & +wliptran*eliptran
 147       endif
 148 #else
 149       if (shield_mode.gt.0) then
 150       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 151      & +welec*fact(1)*(ees+evdw1)
 152      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 153      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 154      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 155      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 156      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 157      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 158      & +wliptran*eliptran
 159       else
 160       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 161      & +welec*fact(1)*(ees+evdw1)
 162      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 163      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 164      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 165      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 166      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 167      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 168      & +wliptran*eliptran
 169       endif
 170 #endif
 171
 172       energia(0)=etot
 173       energia(1)=evdw
 174 #ifdef SCP14
 175       energia(2)=evdw2-evdw2_14
 176       energia(17)=evdw2_14
 177 #else
 178       energia(2)=evdw2
 179       energia(17)=0.0d0
 180 #endif
 181 #ifdef SPLITELE
 182       energia(3)=ees
 183       energia(16)=evdw1
 184 #else
 185       energia(3)=ees+evdw1
 186       energia(16)=0.0d0
 187 #endif
 188       energia(4)=ecorr
 189       energia(5)=ecorr5
 190       energia(6)=ecorr6
 191       energia(7)=eel_loc
 192       energia(8)=eello_turn3
 193       energia(9)=eello_turn4
 194       energia(10)=eturn6
 195       energia(11)=ebe
 196       energia(12)=escloc
 197       energia(13)=etors
 198       energia(14)=etors_d
 199       energia(15)=ehpb
 200       energia(18)=estr
 201       energia(19)=esccor
 202       energia(20)=edihcnstr
 203       energia(21)=evdw_t
 204       energia(24)=ethetacnstr
 205       energia(22)=eliptran
 206 c detecting NaNQ
 207 #ifdef ISNAN
 208 #ifdef AIX
 209       if (isnan(etot).ne.0) energia(0)=1.0d+99
 210 #else
 211       if (isnan(etot)) energia(0)=1.0d+99
 212 #endif
 213 #else
 214       i=0
 215 #ifdef WINPGI
 216       idumm=proc_proc(etot,i)
 217 #else
 218       call proc_proc(etot,i)
 219 #endif
 220       if(i.eq.1)energia(0)=1.0d+99
 221 #endif
 222 #ifdef MPL
 223 c     endif
 224 #endif
 225       if (calc_grad) then
 226 C
 227 C Sum up the components of the Cartesian gradient.
 228 C
 229 #ifdef SPLITELE
 230       do i=1,nct
 231         do j=1,3
 232       if (shield_mode.eq.0) then
 233           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 234      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 235      &                wbond*gradb(j,i)+
 236      &                wstrain*ghpbc(j,i)+
 237      &                wcorr*fact(3)*gradcorr(j,i)+
 238      &                wel_loc*fact(2)*gel_loc(j,i)+
 239      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 240      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 241      &                wcorr5*fact(4)*gradcorr5(j,i)+
 242      &                wcorr6*fact(5)*gradcorr6(j,i)+
 243      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 244      &                wsccor*fact(2)*gsccorc(j,i)
 245      &               +wliptran*gliptranc(j,i)
 246           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 247      &                  wbond*gradbx(j,i)+
 248      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 249      &                  wsccor*fact(2)*gsccorx(j,i)
 250      &                 +wliptran*gliptranx(j,i)
 251         else
 252           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 253      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 254      &               welec*fact(1)*gelc(j,i)+fact(1)*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      &                 +welec*gshieldc(j,i)
 267      &                 +welec*gshieldc_loc(j,i)
 268      &                 +wcorr*gshieldc_ec(j,i)
 269      &                 +wcorr*gshieldc_loc_ec(j,i)
 270      &                 +wturn3*gshieldc_t3(j,i)
 271      &                 +wturn3*gshieldc_loc_t3(j,i)
 272      &                 +wturn4*gshieldc_t4(j,i)
 273      &                 +wturn4*gshieldc_loc_t4(j,i)
 274      &                 +wel_loc*gshieldc_ll(j,i)
 275      &                 +wel_loc*gshieldc_loc_ll(j,i)
 276
 277           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 278      &                 +fact(1)*wscp*gradx_scp(j,i)+
 279      &                  wbond*gradbx(j,i)+
 280      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 281      &                  wsccor*fact(2)*gsccorx(j,i)
 282      &                 +wliptran*gliptranx(j,i)
 283      &                 +welec*gshieldx(j,i)
 284      &                 +wcorr*gshieldx_ec(j,i)
 285      &                 +wturn3*gshieldx_t3(j,i)
 286      &                 +wturn4*gshieldx_t4(j,i)
 287      &                 +wel_loc*gshieldx_ll(j,i)
 288
 289
 290         endif
 291         enddo
 292 #else
 293        do i=1,nct
 294         do j=1,3
 295                 if (shield_mode.eq.0) then
 296           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 297      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 298      &                wbond*gradb(j,i)+
 299      &                wcorr*fact(3)*gradcorr(j,i)+
 300      &                wel_loc*fact(2)*gel_loc(j,i)+
 301      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 302      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 303      &                wcorr5*fact(4)*gradcorr5(j,i)+
 304      &                wcorr6*fact(5)*gradcorr6(j,i)+
 305      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 306      &                wsccor*fact(2)*gsccorc(j,i)
 307      &               +wliptran*gliptranc(j,i)
 308           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 309      &                  wbond*gradbx(j,i)+
 310      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 311      &                  wsccor*fact(1)*gsccorx(j,i)
 312      &                 +wliptran*gliptranx(j,i)
 313               else
 314           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 315      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 316      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 317      &                wbond*gradb(j,i)+
 318      &                wcorr*fact(3)*gradcorr(j,i)+
 319      &                wel_loc*fact(2)*gel_loc(j,i)+
 320      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 321      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 322      &                wcorr5*fact(4)*gradcorr5(j,i)+
 323      &                wcorr6*fact(5)*gradcorr6(j,i)+
 324      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 325      &                wsccor*fact(2)*gsccorc(j,i)
 326      &               +wliptran*gliptranc(j,i)
 327           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 328      &                  fact(1)*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          endif
 334         enddo
 335 #endif
 336       enddo
 337
 338
 339       do i=1,nres-3
 340         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 341      &   +wcorr5*fact(4)*g_corr5_loc(i)
 342      &   +wcorr6*fact(5)*g_corr6_loc(i)
 343      &   +wturn4*fact(3)*gel_loc_turn4(i)
 344      &   +wturn3*fact(2)*gel_loc_turn3(i)
 345      &   +wturn6*fact(5)*gel_loc_turn6(i)
 346      &   +wel_loc*fact(2)*gel_loc_loc(i)
 347 c     &   +wsccor*fact(1)*gsccor_loc(i)
 348 c ROZNICA Z WHAMem
 349       enddo
 350       endif
 351       if (dyn_ss) call dyn_set_nss
 352       return
 353       end
 354 C------------------------------------------------------------------------
 355       subroutine enerprint(energia,fact)
 356       implicit real*8 (a-h,o-z)
 357       include 'DIMENSIONS'
 358       include 'sizesclu.dat'
 359       include 'COMMON.IOUNITS'
 360       include 'COMMON.FFIELD'
 361       include 'COMMON.SBRIDGE'
 362       double precision energia(0:max_ene),fact(6)
 363       etot=energia(0)
 364       evdw=energia(1)+fact(6)*energia(21)
 365 #ifdef SCP14
 366       evdw2=energia(2)+energia(17)
 367 #else
 368       evdw2=energia(2)
 369 #endif
 370       ees=energia(3)
 371 #ifdef SPLITELE
 372       evdw1=energia(16)
 373 #endif
 374       ecorr=energia(4)
 375       ecorr5=energia(5)
 376       ecorr6=energia(6)
 377       eel_loc=energia(7)
 378       eello_turn3=energia(8)
 379       eello_turn4=energia(9)
 380       eello_turn6=energia(10)
 381       ebe=energia(11)
 382       escloc=energia(12)
 383       etors=energia(13)
 384       etors_d=energia(14)
 385       ehpb=energia(15)
 386       esccor=energia(19)
 387       edihcnstr=energia(20)
 388       estr=energia(18)
 389       ethetacnstr=energia(24)
 390 #ifdef SPLITELE
 391       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 392      &  wvdwpp,
 393      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 394      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 395      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 396      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 397      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 398      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,etot
 399    10 format (/'Virtual-chain energies:'//
 400      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 401      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 402      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 403      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 404      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 405      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 406      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 407      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 408      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 409      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 410      & ' (SS bridges & dist. cnstr.)'/
 411      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 412      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 413      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 414      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 415      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 416      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 417      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 418      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 419      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 420      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 421      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 422      & 'ETOT=  ',1pE16.6,' (total)')
 423 #else
 424       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 425      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 426      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 427      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 428      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 429      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 430      &  edihcnstr,ethetacnstr,ebr*nss,etot
 431    10 format (/'Virtual-chain energies:'//
 432      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 433      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 434      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 435      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 436      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 437      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 438      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 439      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 440      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 441      & ' (SS bridges & dist. cnstr.)'/
 442      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 443      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 444      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 445      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 446      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 447      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 448      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 449      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 450      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 451      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 452      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 453      & 'ETOT=  ',1pE16.6,' (total)')
 454 #endif
 455       return
 456       end
 457 C-----------------------------------------------------------------------
 458       subroutine elj(evdw,evdw_t)
 459 C
 460 C This subroutine calculates the interaction energy of nonbonded side chains
 461 C assuming the LJ potential of interaction.
 462 C
 463       implicit real*8 (a-h,o-z)
 464       include 'DIMENSIONS'
 465       include 'sizesclu.dat'
 466       include "DIMENSIONS.COMPAR"
 467       parameter (accur=1.0d-10)
 468       include 'COMMON.GEO'
 469       include 'COMMON.VAR'
 470       include 'COMMON.LOCAL'
 471       include 'COMMON.CHAIN'
 472       include 'COMMON.DERIV'
 473       include 'COMMON.INTERACT'
 474       include 'COMMON.TORSION'
 475       include 'COMMON.SBRIDGE'
 476       include 'COMMON.NAMES'
 477       include 'COMMON.IOUNITS'
 478       include 'COMMON.CONTACTS'
 479       dimension gg(3)
 480       integer icant
 481       external icant
 482 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 483 c ROZNICA DODANE Z WHAM
 484 c      do i=1,210
 485 c        do j=1,2
 486 c          eneps_temp(j,i)=0.0d0
 487 c        enddo
 488 c      enddo
 489 cROZNICA
 490
 491       evdw=0.0D0
 492       evdw_t=0.0d0
 493       do i=iatsc_s,iatsc_e
 494         itypi=iabs(itype(i))
 495         if (itypi.eq.ntyp1) cycle
 496         itypi1=iabs(itype(i+1))
 497         xi=c(1,nres+i)
 498         yi=c(2,nres+i)
 499         zi=c(3,nres+i)
 500 C Change 12/1/95
 501         num_conti=0
 502 C
 503 C Calculate SC interaction energy.
 504 C
 505         do iint=1,nint_gr(i)
 506 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 507 cd   &                  'iend=',iend(i,iint)
 508           do j=istart(i,iint),iend(i,iint)
 509             itypj=iabs(itype(j))
 510             if (itypj.eq.ntyp1) cycle
 511             xj=c(1,nres+j)-xi
 512             yj=c(2,nres+j)-yi
 513             zj=c(3,nres+j)-zi
 514 C Change 12/1/95 to calculate four-body interactions
 515             rij=xj*xj+yj*yj+zj*zj
 516             rrij=1.0D0/rij
 517 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 518             eps0ij=eps(itypi,itypj)
 519             fac=rrij**expon2
 520             e1=fac*fac*aa
 521             e2=fac*bb
 522             evdwij=e1+e2
 523             ij=icant(itypi,itypj)
 524 c ROZNICA z WHAM
 525 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 526 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 527 c
 528
 529 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 530 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 531 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 532 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 533 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 534 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 535             if (bb.gt.0.0d0) then
 536               evdw=evdw+evdwij
 537             else
 538               evdw_t=evdw_t+evdwij
 539             endif
 540             if (calc_grad) then
 541 C
 542 C Calculate the components of the gradient in DC and X
 543 C
 544             fac=-rrij*(e1+evdwij)
 545             gg(1)=xj*fac
 546             gg(2)=yj*fac
 547             gg(3)=zj*fac
 548             do k=1,3
 549               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 550               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 551             enddo
 552             do k=i,j-1
 553               do l=1,3
 554                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 555               enddo
 556             enddo
 557             endif
 558 C
 559 C 12/1/95, revised on 5/20/97
 560 C
 561 C Calculate the contact function. The ith column of the array JCONT will
 562 C contain the numbers of atoms that make contacts with the atom I (of numbers
 563 C greater than I). The arrays FACONT and GACONT will contain the values of
 564 C the contact function and its derivative.
 565 C
 566 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 567 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 568 C Uncomment next line, if the correlation interactions are contact function only
 569             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 570               rij=dsqrt(rij)
 571               sigij=sigma(itypi,itypj)
 572               r0ij=rs0(itypi,itypj)
 573 C
 574 C Check whether the SC's are not too far to make a contact.
 575 C
 576               rcut=1.5d0*r0ij
 577               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 578 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 579 C
 580               if (fcont.gt.0.0D0) then
 581 C If the SC-SC distance if close to sigma, apply spline.
 582 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 583 cAdam &             fcont1,fprimcont1)
 584 cAdam           fcont1=1.0d0-fcont1
 585 cAdam           if (fcont1.gt.0.0d0) then
 586 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 587 cAdam             fcont=fcont*fcont1
 588 cAdam           endif
 589 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 590 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 591 cga             do k=1,3
 592 cga               gg(k)=gg(k)*eps0ij
 593 cga             enddo
 594 cga             eps0ij=-evdwij*eps0ij
 595 C Uncomment for AL's type of SC correlation interactions.
 596 cadam           eps0ij=-evdwij
 597                 num_conti=num_conti+1
 598                 jcont(num_conti,i)=j
 599                 facont(num_conti,i)=fcont*eps0ij
 600                 fprimcont=eps0ij*fprimcont/rij
 601                 fcont=expon*fcont
 602 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 603 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 604 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 605 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 606                 gacont(1,num_conti,i)=-fprimcont*xj
 607                 gacont(2,num_conti,i)=-fprimcont*yj
 608                 gacont(3,num_conti,i)=-fprimcont*zj
 609 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 610 cd              write (iout,'(2i3,3f10.5)')
 611 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 612               endif
 613             endif
 614           enddo      ! j
 615         enddo        ! iint
 616 C Change 12/1/95
 617         num_cont(i)=num_conti
 618       enddo          ! i
 619       if (calc_grad) then
 620       do i=1,nct
 621         do j=1,3
 622           gvdwc(j,i)=expon*gvdwc(j,i)
 623           gvdwx(j,i)=expon*gvdwx(j,i)
 624         enddo
 625       enddo
 626       endif
 627 C******************************************************************************
 628 C
 629 C                              N O T E !!!
 630 C
 631 C To save time, the factor of EXPON has been extracted from ALL components
 632 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 633 C use!
 634 C
 635 C******************************************************************************
 636       return
 637       end
 638 C-----------------------------------------------------------------------------
 639       subroutine eljk(evdw,evdw_t)
 640 C
 641 C This subroutine calculates the interaction energy of nonbonded side chains
 642 C assuming the LJK potential of interaction.
 643 C
 644       implicit real*8 (a-h,o-z)
 645       include 'DIMENSIONS'
 646       include 'sizesclu.dat'
 647       include "DIMENSIONS.COMPAR"
 648       include 'COMMON.GEO'
 649       include 'COMMON.VAR'
 650       include 'COMMON.LOCAL'
 651       include 'COMMON.CHAIN'
 652       include 'COMMON.DERIV'
 653       include 'COMMON.INTERACT'
 654       include 'COMMON.IOUNITS'
 655       include 'COMMON.NAMES'
 656       dimension gg(3)
 657       logical scheck
 658       integer icant
 659       external icant
 660 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 661       evdw=0.0D0
 662       evdw_t=0.0d0
 663       do i=iatsc_s,iatsc_e
 664         itypi=iabs(itype(i))
 665         if (itypi.eq.ntyp1) cycle
 666         itypi1=iabs(itype(i+1))
 667         xi=c(1,nres+i)
 668         yi=c(2,nres+i)
 669         zi=c(3,nres+i)
 670 C
 671 C Calculate SC interaction energy.
 672 C
 673         do iint=1,nint_gr(i)
 674           do j=istart(i,iint),iend(i,iint)
 675             itypj=iabs(itype(j))
 676             if (itypj.eq.ntyp1) cycle
 677             xj=c(1,nres+j)-xi
 678             yj=c(2,nres+j)-yi
 679             zj=c(3,nres+j)-zi
 680             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 681             fac_augm=rrij**expon
 682             e_augm=augm(itypi,itypj)*fac_augm
 683             r_inv_ij=dsqrt(rrij)
 684             rij=1.0D0/r_inv_ij
 685             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 686             fac=r_shift_inv**expon
 687             e1=fac*fac*aa
 688             e2=fac*bb
 689             evdwij=e_augm+e1+e2
 690             ij=icant(itypi,itypj)
 691 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 692 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 693 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 694 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 695 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 696 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 697 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 698             if (bb.gt.0.0d0) then
 699               evdw=evdw+evdwij
 700             else
 701               evdw_t=evdw_t+evdwij
 702             endif
 703             if (calc_grad) then
 704 C
 705 C Calculate the components of the gradient in DC and X
 706 C
 707             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 708             gg(1)=xj*fac
 709             gg(2)=yj*fac
 710             gg(3)=zj*fac
 711             do k=1,3
 712               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 713               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 714             enddo
 715             do k=i,j-1
 716               do l=1,3
 717                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 718               enddo
 719             enddo
 720             endif
 721           enddo      ! j
 722         enddo        ! iint
 723       enddo          ! i
 724       if (calc_grad) then
 725       do i=1,nct
 726         do j=1,3
 727           gvdwc(j,i)=expon*gvdwc(j,i)
 728           gvdwx(j,i)=expon*gvdwx(j,i)
 729         enddo
 730       enddo
 731       endif
 732       return
 733       end
 734 C-----------------------------------------------------------------------------
 735       subroutine ebp(evdw,evdw_t)
 736 C
 737 C This subroutine calculates the interaction energy of nonbonded side chains
 738 C assuming the Berne-Pechukas potential of interaction.
 739 C
 740       implicit real*8 (a-h,o-z)
 741       include 'DIMENSIONS'
 742       include 'sizesclu.dat'
 743       include "DIMENSIONS.COMPAR"
 744       include 'COMMON.GEO'
 745       include 'COMMON.VAR'
 746       include 'COMMON.LOCAL'
 747       include 'COMMON.CHAIN'
 748       include 'COMMON.DERIV'
 749       include 'COMMON.NAMES'
 750       include 'COMMON.INTERACT'
 751       include 'COMMON.IOUNITS'
 752       include 'COMMON.CALC'
 753       common /srutu/ icall
 754 c     double precision rrsave(maxdim)
 755       logical lprn
 756       integer icant
 757       external icant
 758       evdw=0.0D0
 759       evdw_t=0.0d0
 760 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 761 c     if (icall.eq.0) then
 762 c       lprn=.true.
 763 c     else
 764         lprn=.false.
 765 c     endif
 766       ind=0
 767       do i=iatsc_s,iatsc_e
 768         itypi=iabs(itype(i))
 769         if (itypi.eq.ntyp1) cycle
 770         itypi1=iabs(itype(i+1))
 771         xi=c(1,nres+i)
 772         yi=c(2,nres+i)
 773         zi=c(3,nres+i)
 774         dxi=dc_norm(1,nres+i)
 775         dyi=dc_norm(2,nres+i)
 776         dzi=dc_norm(3,nres+i)
 777         dsci_inv=vbld_inv(i+nres)
 778 C
 779 C Calculate SC interaction energy.
 780 C
 781         do iint=1,nint_gr(i)
 782           do j=istart(i,iint),iend(i,iint)
 783             ind=ind+1
 784             itypj=iabs(itype(j))
 785             if (itypj.eq.ntyp1) cycle
 786             dscj_inv=vbld_inv(j+nres)
 787             chi1=chi(itypi,itypj)
 788             chi2=chi(itypj,itypi)
 789             chi12=chi1*chi2
 790             chip1=chip(itypi)
 791             chip2=chip(itypj)
 792             chip12=chip1*chip2
 793             alf1=alp(itypi)
 794             alf2=alp(itypj)
 795             alf12=0.5D0*(alf1+alf2)
 796 C For diagnostics only!!!
 797 c           chi1=0.0D0
 798 c           chi2=0.0D0
 799 c           chi12=0.0D0
 800 c           chip1=0.0D0
 801 c           chip2=0.0D0
 802 c           chip12=0.0D0
 803 c           alf1=0.0D0
 804 c           alf2=0.0D0
 805 c           alf12=0.0D0
 806             xj=c(1,nres+j)-xi
 807             yj=c(2,nres+j)-yi
 808             zj=c(3,nres+j)-zi
 809             dxj=dc_norm(1,nres+j)
 810             dyj=dc_norm(2,nres+j)
 811             dzj=dc_norm(3,nres+j)
 812             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 813 cd          if (icall.eq.0) then
 814 cd            rrsave(ind)=rrij
 815 cd          else
 816 cd            rrij=rrsave(ind)
 817 cd          endif
 818             rij=dsqrt(rrij)
 819 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 820             call sc_angular
 821 C Calculate whole angle-dependent part of epsilon and contributions
 822 C to its derivatives
 823             fac=(rrij*sigsq)**expon2
 824             e1=fac*fac*aa
 825             e2=fac*bb
 826             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 827             eps2der=evdwij*eps3rt
 828             eps3der=evdwij*eps2rt
 829             evdwij=evdwij*eps2rt*eps3rt
 830             ij=icant(itypi,itypj)
 831             aux=eps1*eps2rt**2*eps3rt**2
 832             if (bb.gt.0.0d0) then
 833               evdw=evdw+evdwij
 834             else
 835               evdw_t=evdw_t+evdwij
 836             endif
 837             if (calc_grad) then
 838             if (lprn) then
 839             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 840             epsi=bb**2/aa
 841 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 842 cd     &        restyp(itypi),i,restyp(itypj),j,
 843 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 844 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 845 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 846 cd     &        evdwij
 847             endif
 848 C Calculate gradient components.
 849             e1=e1*eps1*eps2rt**2*eps3rt**2
 850             fac=-expon*(e1+evdwij)
 851             sigder=fac/sigsq
 852             fac=rrij*fac
 853 C Calculate radial part of the gradient
 854             gg(1)=xj*fac
 855             gg(2)=yj*fac
 856             gg(3)=zj*fac
 857 C Calculate the angular part of the gradient and sum add the contributions
 858 C to the appropriate components of the Cartesian gradient.
 859             call sc_grad
 860             endif
 861           enddo      ! j
 862         enddo        ! iint
 863       enddo          ! i
 864 c     stop
 865       return
 866       end
 867 C-----------------------------------------------------------------------------
 868       subroutine egb(evdw,evdw_t)
 869 C
 870 C This subroutine calculates the interaction energy of nonbonded side chains
 871 C assuming the Gay-Berne potential of interaction.
 872 C
 873       implicit real*8 (a-h,o-z)
 874       include 'DIMENSIONS'
 875       include 'sizesclu.dat'
 876       include "DIMENSIONS.COMPAR"
 877       include 'COMMON.GEO'
 878       include 'COMMON.VAR'
 879       include 'COMMON.LOCAL'
 880       include 'COMMON.CHAIN'
 881       include 'COMMON.DERIV'
 882       include 'COMMON.NAMES'
 883       include 'COMMON.INTERACT'
 884       include 'COMMON.IOUNITS'
 885       include 'COMMON.CALC'
 886       include 'COMMON.SBRIDGE'
 887       logical lprn
 888       common /srutu/icall
 889       integer icant
 890       external icant
 891       integer xshift,yshift,zshift
 892       logical energy_dec /.false./
 893 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 894       evdw=0.0D0
 895       evdw_t=0.0d0
 896       lprn=.false.
 897 c      if (icall.gt.0) lprn=.true.
 898       ind=0
 899       do i=iatsc_s,iatsc_e
 900         itypi=iabs(itype(i))
 901         if (itypi.eq.ntyp1) cycle
 902         itypi1=iabs(itype(i+1))
 903         xi=c(1,nres+i)
 904         yi=c(2,nres+i)
 905         zi=c(3,nres+i)
 906           xi=mod(xi,boxxsize)
 907           if (xi.lt.0) xi=xi+boxxsize
 908           yi=mod(yi,boxysize)
 909           if (yi.lt.0) yi=yi+boxysize
 910           zi=mod(zi,boxzsize)
 911           if (zi.lt.0) zi=zi+boxzsize
 912        if ((zi.gt.bordlipbot)
 913      &.and.(zi.lt.bordliptop)) then
 914 C the energy transfer exist
 915         if (zi.lt.buflipbot) then
 916 C what fraction I am in
 917          fracinbuf=1.0d0-
 918      &        ((zi-bordlipbot)/lipbufthick)
 919 C lipbufthick is thickenes of lipid buffore
 920          sslipi=sscalelip(fracinbuf)
 921          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 922         elseif (zi.gt.bufliptop) then
 923          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 924          sslipi=sscalelip(fracinbuf)
 925          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 926         else
 927          sslipi=1.0d0
 928          ssgradlipi=0.0
 929         endif
 930        else
 931          sslipi=0.0d0
 932          ssgradlipi=0.0
 933        endif
 934         dxi=dc_norm(1,nres+i)
 935         dyi=dc_norm(2,nres+i)
 936         dzi=dc_norm(3,nres+i)
 937         dsci_inv=vbld_inv(i+nres)
 938 C
 939 C Calculate SC interaction energy.
 940 C
 941         do iint=1,nint_gr(i)
 942           do j=istart(i,iint),iend(i,iint)
 943             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 944
 945 c              write(iout,*) "PRZED ZWYKLE", evdwij
 946               call dyn_ssbond_ene(i,j,evdwij)
 947 c              write(iout,*) "PO ZWYKLE", evdwij
 948
 949               evdw=evdw+evdwij
 950               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 951      &                        'evdw',i,j,evdwij,' ss'
 952 C triple bond artifac removal
 953              do k=j+1,iend(i,iint)
 954 C search over all next residues
 955               if (dyn_ss_mask(k)) then
 956 C check if they are cysteins
 957 C              write(iout,*) 'k=',k
 958
 959 c              write(iout,*) "PRZED TRI", evdwij
 960                evdwij_przed_tri=evdwij
 961               call triple_ssbond_ene(i,j,k,evdwij)
 962 c               if(evdwij_przed_tri.ne.evdwij) then
 963 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
 964 c               endif
 965
 966 c              write(iout,*) "PO TRI", evdwij
 967 C call the energy function that removes the artifical triple disulfide
 968 C bond the soubroutine is located in ssMD.F
 969               evdw=evdw+evdwij
 970               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 971      &                        'evdw',i,j,evdwij,'tss'
 972               endif!dyn_ss_mask(k)
 973              enddo! k
 974             ELSE
 975             ind=ind+1
 976             itypj=iabs(itype(j))
 977             if (itypj.eq.ntyp1) cycle
 978             dscj_inv=vbld_inv(j+nres)
 979             sig0ij=sigma(itypi,itypj)
 980             chi1=chi(itypi,itypj)
 981             chi2=chi(itypj,itypi)
 982             chi12=chi1*chi2
 983             chip1=chip(itypi)
 984             chip2=chip(itypj)
 985             chip12=chip1*chip2
 986             alf1=alp(itypi)
 987             alf2=alp(itypj)
 988             alf12=0.5D0*(alf1+alf2)
 989 C For diagnostics only!!!
 990 c           chi1=0.0D0
 991 c           chi2=0.0D0
 992 c           chi12=0.0D0
 993 c           chip1=0.0D0
 994 c           chip2=0.0D0
 995 c           chip12=0.0D0
 996 c           alf1=0.0D0
 997 c           alf2=0.0D0
 998 c           alf12=0.0D0
 999             xj=c(1,nres+j)
1000             yj=c(2,nres+j)
1001             zj=c(3,nres+j)
1002           xj=mod(xj,boxxsize)
1003           if (xj.lt.0) xj=xj+boxxsize
1004           yj=mod(yj,boxysize)
1005           if (yj.lt.0) yj=yj+boxysize
1006           zj=mod(zj,boxzsize)
1007           if (zj.lt.0) zj=zj+boxzsize
1008        if ((zj.gt.bordlipbot)
1009      &.and.(zj.lt.bordliptop)) then
1010 C the energy transfer exist
1011         if (zj.lt.buflipbot) then
1012 C what fraction I am in
1013          fracinbuf=1.0d0-
1014      &        ((zj-bordlipbot)/lipbufthick)
1015 C lipbufthick is thickenes of lipid buffore
1016          sslipj=sscalelip(fracinbuf)
1017          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1018         elseif (zj.gt.bufliptop) then
1019          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1020          sslipj=sscalelip(fracinbuf)
1021          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1022         else
1023          sslipj=1.0d0
1024          ssgradlipj=0.0
1025         endif
1026        else
1027          sslipj=0.0d0
1028          ssgradlipj=0.0
1029        endif
1030       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1031      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1032       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1033      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1034 C      write(iout,*) "czy jest 0", bb-bb_lip(itypi,itypj),
1035 C     & bb-bb_aq(itypi,itypj)
1036       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1037       xj_safe=xj
1038       yj_safe=yj
1039       zj_safe=zj
1040       subchap=0
1041       do xshift=-1,1
1042       do yshift=-1,1
1043       do zshift=-1,1
1044           xj=xj_safe+xshift*boxxsize
1045           yj=yj_safe+yshift*boxysize
1046           zj=zj_safe+zshift*boxzsize
1047           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1048           if(dist_temp.lt.dist_init) then
1049             dist_init=dist_temp
1050             xj_temp=xj
1051             yj_temp=yj
1052             zj_temp=zj
1053             subchap=1
1054           endif
1055        enddo
1056        enddo
1057        enddo
1058        if (subchap.eq.1) then
1059           xj=xj_temp-xi
1060           yj=yj_temp-yi
1061           zj=zj_temp-zi
1062        else
1063           xj=xj_safe-xi
1064           yj=yj_safe-yi
1065           zj=zj_safe-zi
1066        endif
1067             dxj=dc_norm(1,nres+j)
1068             dyj=dc_norm(2,nres+j)
1069             dzj=dc_norm(3,nres+j)
1070 c            write (iout,*) i,j,xj,yj,zj
1071             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1072             rij=dsqrt(rrij)
1073             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1074             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1075             if (sss.le.0.0d0) cycle
1076 C Calculate angle-dependent terms of energy and contributions to their
1077 C derivatives.
1078             call sc_angular
1079             sigsq=1.0D0/sigsq
1080             sig=sig0ij*dsqrt(sigsq)
1081             rij_shift=1.0D0/rij-sig+sig0ij
1082 C I hate to put IF's in the loops, but here don't have another choice!!!!
1083             if (rij_shift.le.0.0D0) then
1084               evdw=1.0D20
1085               return
1086             endif
1087             sigder=-sig*sigsq
1088 c---------------------------------------------------------------
1089             rij_shift=1.0D0/rij_shift
1090             fac=rij_shift**expon
1091             e1=fac*fac*aa
1092             e2=fac*bb
1093             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1094             eps2der=evdwij*eps3rt
1095             eps3der=evdwij*eps2rt
1096             evdwij=evdwij*eps2rt*eps3rt
1097             if (bb.gt.0) then
1098               evdw=evdw+evdwij*sss
1099             else
1100               evdw_t=evdw_t+evdwij*sss
1101             endif
1102             ij=icant(itypi,itypj)
1103             aux=eps1*eps2rt**2*eps3rt**2
1104 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1105 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1106 c     &         aux*e2/eps(itypi,itypj)
1107 c            if (lprn) then
1108             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1109             epsi=bb**2/aa
1110 C#define DEBUG
1111 #ifdef DEBUG
1112 C            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1113 C     &        restyp(itypi),i,restyp(itypj),j,
1114 C     &        epsi,sigm,chi1,chi2,chip1,chip2,
1115 C     &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1116 C     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1117 C     &        evdwij
1118              write (iout,*) "pratial sum", evdw,evdw_t,e1,e2,fac,aa
1119 #endif
1120 C#undef DEBUG
1121 c            endif
1122             if (calc_grad) then
1123 C Calculate gradient components.
1124             e1=e1*eps1*eps2rt**2*eps3rt**2
1125             fac=-expon*(e1+evdwij)*rij_shift
1126             sigder=fac*sigder
1127             fac=rij*fac
1128             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1129             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1130      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1131      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1132      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1133             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1134             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1135 C Calculate the radial part of the gradient
1136             gg(1)=xj*fac
1137             gg(2)=yj*fac
1138             gg(3)=zj*fac
1139 C Calculate angular part of the gradient.
1140             call sc_grad
1141             endif
1142             ENDIF    ! dyn_ss
1143           enddo      ! j
1144         enddo        ! iint
1145       enddo          ! i
1146       return
1147       end
1148 C-----------------------------------------------------------------------------
1149       subroutine egbv(evdw,evdw_t)
1150 C
1151 C This subroutine calculates the interaction energy of nonbonded side chains
1152 C assuming the Gay-Berne-Vorobjev potential of interaction.
1153 C
1154       implicit real*8 (a-h,o-z)
1155       include 'DIMENSIONS'
1156       include 'sizesclu.dat'
1157       include "DIMENSIONS.COMPAR"
1158       include 'COMMON.GEO'
1159       include 'COMMON.VAR'
1160       include 'COMMON.LOCAL'
1161       include 'COMMON.CHAIN'
1162       include 'COMMON.DERIV'
1163       include 'COMMON.NAMES'
1164       include 'COMMON.INTERACT'
1165       include 'COMMON.IOUNITS'
1166       include 'COMMON.CALC'
1167       common /srutu/ icall
1168       logical lprn
1169       integer icant
1170       external icant
1171       evdw=0.0D0
1172       evdw_t=0.0d0
1173 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1174       evdw=0.0D0
1175       lprn=.false.
1176 c      if (icall.gt.0) lprn=.true.
1177       ind=0
1178       do i=iatsc_s,iatsc_e
1179         itypi=iabs(itype(i))
1180         if (itypi.eq.ntyp1) cycle
1181         itypi1=iabs(itype(i+1))
1182         xi=c(1,nres+i)
1183         yi=c(2,nres+i)
1184         zi=c(3,nres+i)
1185         dxi=dc_norm(1,nres+i)
1186         dyi=dc_norm(2,nres+i)
1187         dzi=dc_norm(3,nres+i)
1188         dsci_inv=vbld_inv(i+nres)
1189 C returning the ith atom to box
1190           xi=mod(xi,boxxsize)
1191           if (xi.lt.0) xi=xi+boxxsize
1192           yi=mod(yi,boxysize)
1193           if (yi.lt.0) yi=yi+boxysize
1194           zi=mod(zi,boxzsize)
1195           if (zi.lt.0) zi=zi+boxzsize
1196        if ((zi.gt.bordlipbot)
1197      &.and.(zi.lt.bordliptop)) then
1198 C the energy transfer exist
1199         if (zi.lt.buflipbot) then
1200 C what fraction I am in
1201          fracinbuf=1.0d0-
1202      &        ((zi-bordlipbot)/lipbufthick)
1203 C lipbufthick is thickenes of lipid buffore
1204          sslipi=sscalelip(fracinbuf)
1205          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1206         elseif (zi.gt.bufliptop) then
1207          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1208          sslipi=sscalelip(fracinbuf)
1209          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1210         else
1211          sslipi=1.0d0
1212          ssgradlipi=0.0
1213         endif
1214        else
1215          sslipi=0.0d0
1216          ssgradlipi=0.0
1217        endif
1218 C
1219 C Calculate SC interaction energy.
1220 C
1221         do iint=1,nint_gr(i)
1222           do j=istart(i,iint),iend(i,iint)
1223             ind=ind+1
1224             itypj=iabs(itype(j))
1225             if (itypj.eq.ntyp1) cycle
1226             dscj_inv=vbld_inv(j+nres)
1227             sig0ij=sigma(itypi,itypj)
1228             r0ij=r0(itypi,itypj)
1229             chi1=chi(itypi,itypj)
1230             chi2=chi(itypj,itypi)
1231             chi12=chi1*chi2
1232             chip1=chip(itypi)
1233             chip2=chip(itypj)
1234             chip12=chip1*chip2
1235             alf1=alp(itypi)
1236             alf2=alp(itypj)
1237             alf12=0.5D0*(alf1+alf2)
1238 C For diagnostics only!!!
1239 c           chi1=0.0D0
1240 c           chi2=0.0D0
1241 c           chi12=0.0D0
1242 c           chip1=0.0D0
1243 c           chip2=0.0D0
1244 c           chip12=0.0D0
1245 c           alf1=0.0D0
1246 c           alf2=0.0D0
1247 c           alf12=0.0D0
1248             xj=c(1,nres+j)
1249             yj=c(2,nres+j)
1250             zj=c(3,nres+j)
1251 C returning jth atom to box
1252           xj=mod(xj,boxxsize)
1253           if (xj.lt.0) xj=xj+boxxsize
1254           yj=mod(yj,boxysize)
1255           if (yj.lt.0) yj=yj+boxysize
1256           zj=mod(zj,boxzsize)
1257           if (zj.lt.0) zj=zj+boxzsize
1258        if ((zj.gt.bordlipbot)
1259      &.and.(zj.lt.bordliptop)) then
1260 C the energy transfer exist
1261         if (zj.lt.buflipbot) then
1262 C what fraction I am in
1263          fracinbuf=1.0d0-
1264      &        ((zj-bordlipbot)/lipbufthick)
1265 C lipbufthick is thickenes of lipid buffore
1266          sslipj=sscalelip(fracinbuf)
1267          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1268         elseif (zj.gt.bufliptop) then
1269          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1270          sslipj=sscalelip(fracinbuf)
1271          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1272         else
1273          sslipj=1.0d0
1274          ssgradlipj=0.0
1275         endif
1276        else
1277          sslipj=0.0d0
1278          ssgradlipj=0.0
1279        endif
1280       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1281      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1282       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1283      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1284 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1285 C checking the distance
1286       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1287       xj_safe=xj
1288       yj_safe=yj
1289       zj_safe=zj
1290       subchap=0
1291 C finding the closest
1292       do xshift=-1,1
1293       do yshift=-1,1
1294       do zshift=-1,1
1295           xj=xj_safe+xshift*boxxsize
1296           yj=yj_safe+yshift*boxysize
1297           zj=zj_safe+zshift*boxzsize
1298           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1299           if(dist_temp.lt.dist_init) then
1300             dist_init=dist_temp
1301             xj_temp=xj
1302             yj_temp=yj
1303             zj_temp=zj
1304             subchap=1
1305           endif
1306        enddo
1307        enddo
1308        enddo
1309        if (subchap.eq.1) then
1310           xj=xj_temp-xi
1311           yj=yj_temp-yi
1312           zj=zj_temp-zi
1313        else
1314           xj=xj_safe-xi
1315           yj=yj_safe-yi
1316           zj=zj_safe-zi
1317        endif
1318             dxj=dc_norm(1,nres+j)
1319             dyj=dc_norm(2,nres+j)
1320             dzj=dc_norm(3,nres+j)
1321             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1322             rij=dsqrt(rrij)
1323 C Calculate angle-dependent terms of energy and contributions to their
1324 C derivatives.
1325             call sc_angular
1326             sigsq=1.0D0/sigsq
1327             sig=sig0ij*dsqrt(sigsq)
1328             rij_shift=1.0D0/rij-sig+r0ij
1329 C I hate to put IF's in the loops, but here don't have another choice!!!!
1330             if (rij_shift.le.0.0D0) then
1331               evdw=1.0D20
1332               return
1333             endif
1334             sigder=-sig*sigsq
1335 c---------------------------------------------------------------
1336             rij_shift=1.0D0/rij_shift
1337             fac=rij_shift**expon
1338             e1=fac*fac*aa
1339             e2=fac*bb
1340             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1341             eps2der=evdwij*eps3rt
1342             eps3der=evdwij*eps2rt
1343             fac_augm=rrij**expon
1344             e_augm=augm(itypi,itypj)*fac_augm
1345             evdwij=evdwij*eps2rt*eps3rt
1346             if (bb.gt.0.0d0) then
1347               evdw=evdw+evdwij+e_augm
1348             else
1349               evdw_t=evdw_t+evdwij+e_augm
1350             endif
1351             ij=icant(itypi,itypj)
1352             aux=eps1*eps2rt**2*eps3rt**2
1353 c            if (lprn) then
1354 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1355 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1356 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1357 c     &        restyp(itypi),i,restyp(itypj),j,
1358 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1359 c     &        chi1,chi2,chip1,chip2,
1360 c     &        eps1,eps2rt**2,eps3rt**2,
1361 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1362 c     &        evdwij+e_augm
1363 c            endif
1364             if (calc_grad) then
1365 C Calculate gradient components.
1366             e1=e1*eps1*eps2rt**2*eps3rt**2
1367             fac=-expon*(e1+evdwij)*rij_shift
1368             sigder=fac*sigder
1369             fac=rij*fac-2*expon*rrij*e_augm
1370 C Calculate the radial part of the gradient
1371             gg(1)=xj*fac
1372             gg(2)=yj*fac
1373             gg(3)=zj*fac
1374 C Calculate angular part of the gradient.
1375             call sc_grad
1376             endif
1377           enddo      ! j
1378         enddo        ! iint
1379       enddo          ! i
1380       return
1381       end
1382 C-----------------------------------------------------------------------------
1383       subroutine sc_angular
1384 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1385 C om12. Called by ebp, egb, and egbv.
1386       implicit none
1387       include 'COMMON.CALC'
1388       erij(1)=xj*rij
1389       erij(2)=yj*rij
1390       erij(3)=zj*rij
1391       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1392       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1393       om12=dxi*dxj+dyi*dyj+dzi*dzj
1394       chiom12=chi12*om12
1395 C Calculate eps1(om12) and its derivative in om12
1396       faceps1=1.0D0-om12*chiom12
1397       faceps1_inv=1.0D0/faceps1
1398       eps1=dsqrt(faceps1_inv)
1399 C Following variable is eps1*deps1/dom12
1400       eps1_om12=faceps1_inv*chiom12
1401 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1402 C and om12.
1403       om1om2=om1*om2
1404       chiom1=chi1*om1
1405       chiom2=chi2*om2
1406       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1407       sigsq=1.0D0-facsig*faceps1_inv
1408       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1409       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1410       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1411 C Calculate eps2 and its derivatives in om1, om2, and om12.
1412       chipom1=chip1*om1
1413       chipom2=chip2*om2
1414       chipom12=chip12*om12
1415       facp=1.0D0-om12*chipom12
1416       facp_inv=1.0D0/facp
1417       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1418 C Following variable is the square root of eps2
1419       eps2rt=1.0D0-facp1*facp_inv
1420 C Following three variables are the derivatives of the square root of eps
1421 C in om1, om2, and om12.
1422       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1423       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1424       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1425 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1426       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1427 C Calculate whole angle-dependent part of epsilon and contributions
1428 C to its derivatives
1429       return
1430       end
1431 C----------------------------------------------------------------------------
1432       subroutine sc_grad
1433       implicit real*8 (a-h,o-z)
1434       include 'DIMENSIONS'
1435       include 'sizesclu.dat'
1436       include 'COMMON.CHAIN'
1437       include 'COMMON.DERIV'
1438       include 'COMMON.CALC'
1439       double precision dcosom1(3),dcosom2(3)
1440       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1441       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1442       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1443      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1444       do k=1,3
1445         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1446         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1447       enddo
1448       do k=1,3
1449         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1450       enddo
1451       do k=1,3
1452         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1453      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1454      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1455         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipi(k)
1456      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1457      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1458       enddo
1459 C
1460 C Calculate the components of the gradient in DC and X
1461 C
1462       do k=i,j-1
1463         do l=1,3
1464           gvdwc(l,k)=gvdwc(l,k)+gg(l)+gg_lipi(l)
1465         enddo
1466       enddo
1467       do l=1,3
1468          gvdwc(l,j)=gvdwc(l,j)+gg_lipj(l)
1469       enddo
1470       return
1471       end
1472 c------------------------------------------------------------------------------
1473       subroutine vec_and_deriv
1474       implicit real*8 (a-h,o-z)
1475       include 'DIMENSIONS'
1476       include 'sizesclu.dat'
1477       include 'COMMON.IOUNITS'
1478       include 'COMMON.GEO'
1479       include 'COMMON.VAR'
1480       include 'COMMON.LOCAL'
1481       include 'COMMON.CHAIN'
1482       include 'COMMON.VECTORS'
1483       include 'COMMON.DERIV'
1484       include 'COMMON.INTERACT'
1485       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1486 C Compute the local reference systems. For reference system (i), the
1487 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1488 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1489       do i=1,nres-1
1490 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1491           if (i.eq.nres-1) then
1492 C Case of the last full residue
1493 C Compute the Z-axis
1494             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1495             costh=dcos(pi-theta(nres))
1496             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1497             do k=1,3
1498               uz(k,i)=fac*uz(k,i)
1499             enddo
1500             if (calc_grad) then
1501 C Compute the derivatives of uz
1502             uzder(1,1,1)= 0.0d0
1503             uzder(2,1,1)=-dc_norm(3,i-1)
1504             uzder(3,1,1)= dc_norm(2,i-1)
1505             uzder(1,2,1)= dc_norm(3,i-1)
1506             uzder(2,2,1)= 0.0d0
1507             uzder(3,2,1)=-dc_norm(1,i-1)
1508             uzder(1,3,1)=-dc_norm(2,i-1)
1509             uzder(2,3,1)= dc_norm(1,i-1)
1510             uzder(3,3,1)= 0.0d0
1511             uzder(1,1,2)= 0.0d0
1512             uzder(2,1,2)= dc_norm(3,i)
1513             uzder(3,1,2)=-dc_norm(2,i)
1514             uzder(1,2,2)=-dc_norm(3,i)
1515             uzder(2,2,2)= 0.0d0
1516             uzder(3,2,2)= dc_norm(1,i)
1517             uzder(1,3,2)= dc_norm(2,i)
1518             uzder(2,3,2)=-dc_norm(1,i)
1519             uzder(3,3,2)= 0.0d0
1520             endif
1521 C Compute the Y-axis
1522             facy=fac
1523             do k=1,3
1524               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1525             enddo
1526             if (calc_grad) then
1527 C Compute the derivatives of uy
1528             do j=1,3
1529               do k=1,3
1530                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1531      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1532                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1533               enddo
1534               uyder(j,j,1)=uyder(j,j,1)-costh
1535               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1536             enddo
1537             do j=1,2
1538               do k=1,3
1539                 do l=1,3
1540                   uygrad(l,k,j,i)=uyder(l,k,j)
1541                   uzgrad(l,k,j,i)=uzder(l,k,j)
1542                 enddo
1543               enddo
1544             enddo
1545             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1546             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1547             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1548             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1549             endif
1550           else
1551 C Other residues
1552 C Compute the Z-axis
1553             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1554             costh=dcos(pi-theta(i+2))
1555             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1556             do k=1,3
1557               uz(k,i)=fac*uz(k,i)
1558             enddo
1559             if (calc_grad) then
1560 C Compute the derivatives of uz
1561             uzder(1,1,1)= 0.0d0
1562             uzder(2,1,1)=-dc_norm(3,i+1)
1563             uzder(3,1,1)= dc_norm(2,i+1)
1564             uzder(1,2,1)= dc_norm(3,i+1)
1565             uzder(2,2,1)= 0.0d0
1566             uzder(3,2,1)=-dc_norm(1,i+1)
1567             uzder(1,3,1)=-dc_norm(2,i+1)
1568             uzder(2,3,1)= dc_norm(1,i+1)
1569             uzder(3,3,1)= 0.0d0
1570             uzder(1,1,2)= 0.0d0
1571             uzder(2,1,2)= dc_norm(3,i)
1572             uzder(3,1,2)=-dc_norm(2,i)
1573             uzder(1,2,2)=-dc_norm(3,i)
1574             uzder(2,2,2)= 0.0d0
1575             uzder(3,2,2)= dc_norm(1,i)
1576             uzder(1,3,2)= dc_norm(2,i)
1577             uzder(2,3,2)=-dc_norm(1,i)
1578             uzder(3,3,2)= 0.0d0
1579             endif
1580 C Compute the Y-axis
1581             facy=fac
1582             do k=1,3
1583               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1584             enddo
1585             if (calc_grad) then
1586 C Compute the derivatives of uy
1587             do j=1,3
1588               do k=1,3
1589                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1590      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1591                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1592               enddo
1593               uyder(j,j,1)=uyder(j,j,1)-costh
1594               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1595             enddo
1596             do j=1,2
1597               do k=1,3
1598                 do l=1,3
1599                   uygrad(l,k,j,i)=uyder(l,k,j)
1600                   uzgrad(l,k,j,i)=uzder(l,k,j)
1601                 enddo
1602               enddo
1603             enddo
1604             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1605             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1606             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1607             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1608           endif
1609           endif
1610       enddo
1611       if (calc_grad) then
1612       do i=1,nres-1
1613         vbld_inv_temp(1)=vbld_inv(i+1)
1614         if (i.lt.nres-1) then
1615           vbld_inv_temp(2)=vbld_inv(i+2)
1616         else
1617           vbld_inv_temp(2)=vbld_inv(i)
1618         endif
1619         do j=1,2
1620           do k=1,3
1621             do l=1,3
1622               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1623               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1624             enddo
1625           enddo
1626         enddo
1627       enddo
1628       endif
1629       return
1630       end
1631 C-----------------------------------------------------------------------------
1632       subroutine vec_and_deriv_test
1633       implicit real*8 (a-h,o-z)
1634       include 'DIMENSIONS'
1635       include 'sizesclu.dat'
1636       include 'COMMON.IOUNITS'
1637       include 'COMMON.GEO'
1638       include 'COMMON.VAR'
1639       include 'COMMON.LOCAL'
1640       include 'COMMON.CHAIN'
1641       include 'COMMON.VECTORS'
1642       dimension uyder(3,3,2),uzder(3,3,2)
1643 C Compute the local reference systems. For reference system (i), the
1644 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1645 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1646       do i=1,nres-1
1647           if (i.eq.nres-1) then
1648 C Case of the last full residue
1649 C Compute the Z-axis
1650             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1651             costh=dcos(pi-theta(nres))
1652             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1653 c            write (iout,*) 'fac',fac,
1654 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1655             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1656             do k=1,3
1657               uz(k,i)=fac*uz(k,i)
1658             enddo
1659 C Compute the derivatives of uz
1660             uzder(1,1,1)= 0.0d0
1661             uzder(2,1,1)=-dc_norm(3,i-1)
1662             uzder(3,1,1)= dc_norm(2,i-1)
1663             uzder(1,2,1)= dc_norm(3,i-1)
1664             uzder(2,2,1)= 0.0d0
1665             uzder(3,2,1)=-dc_norm(1,i-1)
1666             uzder(1,3,1)=-dc_norm(2,i-1)
1667             uzder(2,3,1)= dc_norm(1,i-1)
1668             uzder(3,3,1)= 0.0d0
1669             uzder(1,1,2)= 0.0d0
1670             uzder(2,1,2)= dc_norm(3,i)
1671             uzder(3,1,2)=-dc_norm(2,i)
1672             uzder(1,2,2)=-dc_norm(3,i)
1673             uzder(2,2,2)= 0.0d0
1674             uzder(3,2,2)= dc_norm(1,i)
1675             uzder(1,3,2)= dc_norm(2,i)
1676             uzder(2,3,2)=-dc_norm(1,i)
1677             uzder(3,3,2)= 0.0d0
1678 C Compute the Y-axis
1679             do k=1,3
1680               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1681             enddo
1682             facy=fac
1683             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1684      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1685      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1686             do k=1,3
1687 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1688               uy(k,i)=
1689 c     &        facy*(
1690      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1691      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1692 c     &        )
1693             enddo
1694 c            write (iout,*) 'facy',facy,
1695 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1696             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1697             do k=1,3
1698               uy(k,i)=facy*uy(k,i)
1699             enddo
1700 C Compute the derivatives of uy
1701             do j=1,3
1702               do k=1,3
1703                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1704      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1705                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1706               enddo
1707 c              uyder(j,j,1)=uyder(j,j,1)-costh
1708 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1709               uyder(j,j,1)=uyder(j,j,1)
1710      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1711               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1712      &          +uyder(j,j,2)
1713             enddo
1714             do j=1,2
1715               do k=1,3
1716                 do l=1,3
1717                   uygrad(l,k,j,i)=uyder(l,k,j)
1718                   uzgrad(l,k,j,i)=uzder(l,k,j)
1719                 enddo
1720               enddo
1721             enddo
1722             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1723             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1724             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1725             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1726           else
1727 C Other residues
1728 C Compute the Z-axis
1729             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1730             costh=dcos(pi-theta(i+2))
1731             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1732             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1733             do k=1,3
1734               uz(k,i)=fac*uz(k,i)
1735             enddo
1736 C Compute the derivatives of uz
1737             uzder(1,1,1)= 0.0d0
1738             uzder(2,1,1)=-dc_norm(3,i+1)
1739             uzder(3,1,1)= dc_norm(2,i+1)
1740             uzder(1,2,1)= dc_norm(3,i+1)
1741             uzder(2,2,1)= 0.0d0
1742             uzder(3,2,1)=-dc_norm(1,i+1)
1743             uzder(1,3,1)=-dc_norm(2,i+1)
1744             uzder(2,3,1)= dc_norm(1,i+1)
1745             uzder(3,3,1)= 0.0d0
1746             uzder(1,1,2)= 0.0d0
1747             uzder(2,1,2)= dc_norm(3,i)
1748             uzder(3,1,2)=-dc_norm(2,i)
1749             uzder(1,2,2)=-dc_norm(3,i)
1750             uzder(2,2,2)= 0.0d0
1751             uzder(3,2,2)= dc_norm(1,i)
1752             uzder(1,3,2)= dc_norm(2,i)
1753             uzder(2,3,2)=-dc_norm(1,i)
1754             uzder(3,3,2)= 0.0d0
1755 C Compute the Y-axis
1756             facy=fac
1757             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1758      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1759      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1760             do k=1,3
1761 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1762               uy(k,i)=
1763 c     &        facy*(
1764      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1765      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1766 c     &        )
1767             enddo
1768 c            write (iout,*) 'facy',facy,
1769 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1770             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1771             do k=1,3
1772               uy(k,i)=facy*uy(k,i)
1773             enddo
1774 C Compute the derivatives of uy
1775             do j=1,3
1776               do k=1,3
1777                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1778      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1779                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1780               enddo
1781 c              uyder(j,j,1)=uyder(j,j,1)-costh
1782 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1783               uyder(j,j,1)=uyder(j,j,1)
1784      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1785               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1786      &          +uyder(j,j,2)
1787             enddo
1788             do j=1,2
1789               do k=1,3
1790                 do l=1,3
1791                   uygrad(l,k,j,i)=uyder(l,k,j)
1792                   uzgrad(l,k,j,i)=uzder(l,k,j)
1793                 enddo
1794               enddo
1795             enddo
1796             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1797             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1798             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1799             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1800           endif
1801       enddo
1802       do i=1,nres-1
1803         do j=1,2
1804           do k=1,3
1805             do l=1,3
1806               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1807               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1808             enddo
1809           enddo
1810         enddo
1811       enddo
1812       return
1813       end
1814 C-----------------------------------------------------------------------------
1815       subroutine check_vecgrad
1816       implicit real*8 (a-h,o-z)
1817       include 'DIMENSIONS'
1818       include 'sizesclu.dat'
1819       include 'COMMON.IOUNITS'
1820       include 'COMMON.GEO'
1821       include 'COMMON.VAR'
1822       include 'COMMON.LOCAL'
1823       include 'COMMON.CHAIN'
1824       include 'COMMON.VECTORS'
1825       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1826       dimension uyt(3,maxres),uzt(3,maxres)
1827       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1828       double precision delta /1.0d-7/
1829       call vec_and_deriv
1830 cd      do i=1,nres
1831 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1832 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1833 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1834 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1835 cd     &     (dc_norm(if90,i),if90=1,3)
1836 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1837 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1838 cd          write(iout,'(a)')
1839 cd      enddo
1840       do i=1,nres
1841         do j=1,2
1842           do k=1,3
1843             do l=1,3
1844               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1845               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1846             enddo
1847           enddo
1848         enddo
1849       enddo
1850       call vec_and_deriv
1851       do i=1,nres
1852         do j=1,3
1853           uyt(j,i)=uy(j,i)
1854           uzt(j,i)=uz(j,i)
1855         enddo
1856       enddo
1857       do i=1,nres
1858 cd        write (iout,*) 'i=',i
1859         do k=1,3
1860           erij(k)=dc_norm(k,i)
1861         enddo
1862         do j=1,3
1863           do k=1,3
1864             dc_norm(k,i)=erij(k)
1865           enddo
1866           dc_norm(j,i)=dc_norm(j,i)+delta
1867 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1868 c          do k=1,3
1869 c            dc_norm(k,i)=dc_norm(k,i)/fac
1870 c          enddo
1871 c          write (iout,*) (dc_norm(k,i),k=1,3)
1872 c          write (iout,*) (erij(k),k=1,3)
1873           call vec_and_deriv
1874           do k=1,3
1875             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1876             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1877             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1878             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1879           enddo
1880 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1881 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1882 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1883         enddo
1884         do k=1,3
1885           dc_norm(k,i)=erij(k)
1886         enddo
1887 cd        do k=1,3
1888 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1889 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1890 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1891 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1892 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1893 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1894 cd          write (iout,'(a)')
1895 cd        enddo
1896       enddo
1897       return
1898       end
1899 C--------------------------------------------------------------------------
1900       subroutine set_matrices
1901       implicit real*8 (a-h,o-z)
1902       include 'DIMENSIONS'
1903       include 'sizesclu.dat'
1904       include 'COMMON.IOUNITS'
1905       include 'COMMON.GEO'
1906       include 'COMMON.VAR'
1907       include 'COMMON.LOCAL'
1908       include 'COMMON.CHAIN'
1909       include 'COMMON.DERIV'
1910       include 'COMMON.INTERACT'
1911       include 'COMMON.CONTACTS'
1912       include 'COMMON.TORSION'
1913       include 'COMMON.VECTORS'
1914       include 'COMMON.FFIELD'
1915       double precision auxvec(2),auxmat(2,2)
1916 C
1917 C Compute the virtual-bond-torsional-angle dependent quantities needed
1918 C to calculate the el-loc multibody terms of various order.
1919 C
1920       do i=3,nres+1
1921         if (i .lt. nres+1) then
1922           sin1=dsin(phi(i))
1923           cos1=dcos(phi(i))
1924           sintab(i-2)=sin1
1925           costab(i-2)=cos1
1926           obrot(1,i-2)=cos1
1927           obrot(2,i-2)=sin1
1928           sin2=dsin(2*phi(i))
1929           cos2=dcos(2*phi(i))
1930           sintab2(i-2)=sin2
1931           costab2(i-2)=cos2
1932           obrot2(1,i-2)=cos2
1933           obrot2(2,i-2)=sin2
1934           Ug(1,1,i-2)=-cos1
1935           Ug(1,2,i-2)=-sin1
1936           Ug(2,1,i-2)=-sin1
1937           Ug(2,2,i-2)= cos1
1938           Ug2(1,1,i-2)=-cos2
1939           Ug2(1,2,i-2)=-sin2
1940           Ug2(2,1,i-2)=-sin2
1941           Ug2(2,2,i-2)= cos2
1942         else
1943           costab(i-2)=1.0d0
1944           sintab(i-2)=0.0d0
1945           obrot(1,i-2)=1.0d0
1946           obrot(2,i-2)=0.0d0
1947           obrot2(1,i-2)=0.0d0
1948           obrot2(2,i-2)=0.0d0
1949           Ug(1,1,i-2)=1.0d0
1950           Ug(1,2,i-2)=0.0d0
1951           Ug(2,1,i-2)=0.0d0
1952           Ug(2,2,i-2)=1.0d0
1953           Ug2(1,1,i-2)=0.0d0
1954           Ug2(1,2,i-2)=0.0d0
1955           Ug2(2,1,i-2)=0.0d0
1956           Ug2(2,2,i-2)=0.0d0
1957         endif
1958         if (i .gt. 3 .and. i .lt. nres+1) then
1959           obrot_der(1,i-2)=-sin1
1960           obrot_der(2,i-2)= cos1
1961           Ugder(1,1,i-2)= sin1
1962           Ugder(1,2,i-2)=-cos1
1963           Ugder(2,1,i-2)=-cos1
1964           Ugder(2,2,i-2)=-sin1
1965           dwacos2=cos2+cos2
1966           dwasin2=sin2+sin2
1967           obrot2_der(1,i-2)=-dwasin2
1968           obrot2_der(2,i-2)= dwacos2
1969           Ug2der(1,1,i-2)= dwasin2
1970           Ug2der(1,2,i-2)=-dwacos2
1971           Ug2der(2,1,i-2)=-dwacos2
1972           Ug2der(2,2,i-2)=-dwasin2
1973         else
1974           obrot_der(1,i-2)=0.0d0
1975           obrot_der(2,i-2)=0.0d0
1976           Ugder(1,1,i-2)=0.0d0
1977           Ugder(1,2,i-2)=0.0d0
1978           Ugder(2,1,i-2)=0.0d0
1979           Ugder(2,2,i-2)=0.0d0
1980           obrot2_der(1,i-2)=0.0d0
1981           obrot2_der(2,i-2)=0.0d0
1982           Ug2der(1,1,i-2)=0.0d0
1983           Ug2der(1,2,i-2)=0.0d0
1984           Ug2der(2,1,i-2)=0.0d0
1985           Ug2der(2,2,i-2)=0.0d0
1986         endif
1987         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1988           if (itype(i-2).le.ntyp) then
1989             iti = itortyp(itype(i-2))
1990           else
1991             iti=ntortyp+1
1992           endif
1993         else
1994           iti=ntortyp+1
1995         endif
1996         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1997           if (itype(i-1).le.ntyp) then
1998             iti1 = itortyp(itype(i-1))
1999           else
2000             iti1=ntortyp+1
2001           endif
2002         else
2003           iti1=ntortyp+1
2004         endif
2005 cd        write (iout,*) '*******i',i,' iti1',iti
2006 cd        write (iout,*) 'b1',b1(:,iti)
2007 cd        write (iout,*) 'b2',b2(:,iti)
2008 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2009 c        print *,"itilde1 i iti iti1",i,iti,iti1
2010         if (i .gt. iatel_s+2) then
2011           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2012           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2013           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2014           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2015           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2016           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2017           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2018         else
2019           do k=1,2
2020             Ub2(k,i-2)=0.0d0
2021             Ctobr(k,i-2)=0.0d0
2022             Dtobr2(k,i-2)=0.0d0
2023             do l=1,2
2024               EUg(l,k,i-2)=0.0d0
2025               CUg(l,k,i-2)=0.0d0
2026               DUg(l,k,i-2)=0.0d0
2027               DtUg2(l,k,i-2)=0.0d0
2028             enddo
2029           enddo
2030         endif
2031 c        print *,"itilde2 i iti iti1",i,iti,iti1
2032         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2033         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2034         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2035         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2036         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2037         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2038         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2039 c        print *,"itilde3 i iti iti1",i,iti,iti1
2040         do k=1,2
2041           muder(k,i-2)=Ub2der(k,i-2)
2042         enddo
2043         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2044           if (itype(i-1).le.ntyp) then
2045             iti1 = itortyp(itype(i-1))
2046           else
2047             iti1=ntortyp+1
2048           endif
2049         else
2050           iti1=ntortyp+1
2051         endif
2052         do k=1,2
2053           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2054         enddo
2055 C Vectors and matrices dependent on a single virtual-bond dihedral.
2056         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2057         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2058         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2059         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2060         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2061         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2062         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2063         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2064         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2065 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2066 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2067       enddo
2068 C Matrices dependent on two consecutive virtual-bond dihedrals.
2069 C The order of matrices is from left to right.
2070       do i=2,nres-1
2071         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2072         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2073         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2074         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2075         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2076         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2077         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2078         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2079       enddo
2080 cd      do i=1,nres
2081 cd        iti = itortyp(itype(i))
2082 cd        write (iout,*) i
2083 cd        do j=1,2
2084 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2085 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2086 cd        enddo
2087 cd      enddo
2088       return
2089       end
2090 C--------------------------------------------------------------------------
2091       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2092 C
2093 C This subroutine calculates the average interaction energy and its gradient
2094 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2095 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2096 C The potential depends both on the distance of peptide-group centers and on
2097 C the orientation of the CA-CA virtual bonds.
2098 C
2099       implicit real*8 (a-h,o-z)
2100       include 'DIMENSIONS'
2101       include 'sizesclu.dat'
2102       include 'COMMON.CONTROL'
2103       include 'COMMON.IOUNITS'
2104       include 'COMMON.GEO'
2105       include 'COMMON.VAR'
2106       include 'COMMON.LOCAL'
2107       include 'COMMON.CHAIN'
2108       include 'COMMON.DERIV'
2109       include 'COMMON.INTERACT'
2110       include 'COMMON.CONTACTS'
2111       include 'COMMON.TORSION'
2112       include 'COMMON.VECTORS'
2113       include 'COMMON.FFIELD'
2114       include 'COMMON.SHIELD'
2115
2116       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2117      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2118       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2119      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2120       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2121 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2122       double precision scal_el /0.5d0/
2123 C 12/13/98
2124 C 13-go grudnia roku pamietnego...
2125       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2126      &                   0.0d0,1.0d0,0.0d0,
2127      &                   0.0d0,0.0d0,1.0d0/
2128 cd      write(iout,*) 'In EELEC'
2129 cd      do i=1,nloctyp
2130 cd        write(iout,*) 'Type',i
2131 cd        write(iout,*) 'B1',B1(:,i)
2132 cd        write(iout,*) 'B2',B2(:,i)
2133 cd        write(iout,*) 'CC',CC(:,:,i)
2134 cd        write(iout,*) 'DD',DD(:,:,i)
2135 cd        write(iout,*) 'EE',EE(:,:,i)
2136 cd      enddo
2137 cd      call check_vecgrad
2138 cd      stop
2139       if (icheckgrad.eq.1) then
2140         do i=1,nres-1
2141           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2142           do k=1,3
2143             dc_norm(k,i)=dc(k,i)*fac
2144           enddo
2145 c          write (iout,*) 'i',i,' fac',fac
2146         enddo
2147       endif
2148       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2149      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2150      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2151 cd      if (wel_loc.gt.0.0d0) then
2152         if (icheckgrad.eq.1) then
2153         call vec_and_deriv_test
2154         else
2155         call vec_and_deriv
2156         endif
2157         call set_matrices
2158       endif
2159 cd      do i=1,nres-1
2160 cd        write (iout,*) 'i=',i
2161 cd        do k=1,3
2162 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2163 cd        enddo
2164 cd        do k=1,3
2165 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2166 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2167 cd        enddo
2168 cd      enddo
2169       num_conti_hb=0
2170       ees=0.0D0
2171       evdw1=0.0D0
2172       eel_loc=0.0d0
2173       eello_turn3=0.0d0
2174       eello_turn4=0.0d0
2175       ind=0
2176       do i=1,nres
2177         num_cont_hb(i)=0
2178       enddo
2179 cd      print '(a)','Enter EELEC'
2180 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2181       do i=1,nres
2182         gel_loc_loc(i)=0.0d0
2183         gcorr_loc(i)=0.0d0
2184       enddo
2185       do i=iatel_s,iatel_e
2186 C          if (i.eq.1) then
2187            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2188 C     &  .or. itype(i+2).eq.ntyp1) cycle
2189 C          else
2190 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2191 C     &  .or. itype(i+2).eq.ntyp1
2192 C     &  .or. itype(i-1).eq.ntyp1
2193      &) cycle
2194 C         endif
2195         if (itel(i).eq.0) goto 1215
2196         dxi=dc(1,i)
2197         dyi=dc(2,i)
2198         dzi=dc(3,i)
2199         dx_normi=dc_norm(1,i)
2200         dy_normi=dc_norm(2,i)
2201         dz_normi=dc_norm(3,i)
2202         xmedi=c(1,i)+0.5d0*dxi
2203         ymedi=c(2,i)+0.5d0*dyi
2204         zmedi=c(3,i)+0.5d0*dzi
2205           xmedi=mod(xmedi,boxxsize)
2206           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2207           ymedi=mod(ymedi,boxysize)
2208           if (ymedi.lt.0) ymedi=ymedi+boxysize
2209           zmedi=mod(zmedi,boxzsize)
2210           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2211         num_conti=0
2212 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2213         do j=ielstart(i),ielend(i)
2214 C          if (j.le.1) cycle
2215 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2216 C     & .or.itype(j+2).eq.ntyp1
2217 C     &) cycle
2218 C          else
2219           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2220 C     & .or.itype(j+2).eq.ntyp1
2221 C     & .or.itype(j-1).eq.ntyp1
2222      &) cycle
2223 C         endif
2224           if (itel(j).eq.0) goto 1216
2225           ind=ind+1
2226           iteli=itel(i)
2227           itelj=itel(j)
2228           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2229           aaa=app(iteli,itelj)
2230           bbb=bpp(iteli,itelj)
2231 C Diagnostics only!!!
2232 c         aaa=0.0D0
2233 c         bbb=0.0D0
2234 c         ael6i=0.0D0
2235 c         ael3i=0.0D0
2236 C End diagnostics
2237           ael6i=ael6(iteli,itelj)
2238           ael3i=ael3(iteli,itelj)
2239           dxj=dc(1,j)
2240           dyj=dc(2,j)
2241           dzj=dc(3,j)
2242           dx_normj=dc_norm(1,j)
2243           dy_normj=dc_norm(2,j)
2244           dz_normj=dc_norm(3,j)
2245           xj=c(1,j)+0.5D0*dxj
2246           yj=c(2,j)+0.5D0*dyj
2247           zj=c(3,j)+0.5D0*dzj
2248          xj=mod(xj,boxxsize)
2249           if (xj.lt.0) xj=xj+boxxsize
2250           yj=mod(yj,boxysize)
2251           if (yj.lt.0) yj=yj+boxysize
2252           zj=mod(zj,boxzsize)
2253           if (zj.lt.0) zj=zj+boxzsize
2254       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2255       xj_safe=xj
2256       yj_safe=yj
2257       zj_safe=zj
2258       isubchap=0
2259       do xshift=-1,1
2260       do yshift=-1,1
2261       do zshift=-1,1
2262           xj=xj_safe+xshift*boxxsize
2263           yj=yj_safe+yshift*boxysize
2264           zj=zj_safe+zshift*boxzsize
2265           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2266           if(dist_temp.lt.dist_init) then
2267             dist_init=dist_temp
2268             xj_temp=xj
2269             yj_temp=yj
2270             zj_temp=zj
2271             isubchap=1
2272           endif
2273        enddo
2274        enddo
2275        enddo
2276        if (isubchap.eq.1) then
2277           xj=xj_temp-xmedi
2278           yj=yj_temp-ymedi
2279           zj=zj_temp-zmedi
2280        else
2281           xj=xj_safe-xmedi
2282           yj=yj_safe-ymedi
2283           zj=zj_safe-zmedi
2284        endif
2285
2286           rij=xj*xj+yj*yj+zj*zj
2287             sss=sscale(sqrt(rij))
2288             sssgrad=sscagrad(sqrt(rij))
2289           rrmij=1.0D0/rij
2290           rij=dsqrt(rij)
2291           rmij=1.0D0/rij
2292           r3ij=rrmij*rmij
2293           r6ij=r3ij*r3ij
2294           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2295           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2296           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2297           fac=cosa-3.0D0*cosb*cosg
2298           ev1=aaa*r6ij*r6ij
2299 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2300           if (j.eq.i+2) ev1=scal_el*ev1
2301           ev2=bbb*r6ij
2302           fac3=ael6i*r6ij
2303           fac4=ael3i*r3ij
2304           evdwij=ev1+ev2
2305           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2306           el2=fac4*fac
2307           eesij=el1+el2
2308 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2309 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2310           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2311           if (shield_mode.gt.0) then
2312 C          fac_shield(i)=0.4
2313 C          fac_shield(j)=0.6
2314 C#define DEBUG
2315 #ifdef DEBUG
2316           write(iout,*) "ees_compon",i,j,el1,el2,
2317      &    fac_shield(i),fac_shield(j)
2318 #endif
2319 C#undef DEBUG
2320           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2321           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2322           eesij=(el1+el2)
2323           ees=ees+eesij
2324           else
2325           fac_shield(i)=1.0
2326           fac_shield(j)=1.0
2327           eesij=(el1+el2)
2328           ees=ees+eesij
2329           endif
2330 C          ees=ees+eesij
2331           evdw1=evdw1+evdwij*sss
2332 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2333 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2334 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2335 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2336 C
2337 C Calculate contributions to the Cartesian gradient.
2338 C
2339 #ifdef SPLITELE
2340           facvdw=-6*rrmij*(ev1+evdwij)*sss
2341           facel=-3*rrmij*(el1+eesij)
2342           fac1=fac
2343           erij(1)=xj*rmij
2344           erij(2)=yj*rmij
2345           erij(3)=zj*rmij
2346           if (calc_grad) then
2347 *
2348 * Radial derivatives. First process both termini of the fragment (i,j)
2349 *
2350           ggg(1)=facel*xj
2351           ggg(2)=facel*yj
2352           ggg(3)=facel*zj
2353
2354           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2355      &  (shield_mode.gt.0)) then
2356 C          print *,i,j
2357           do ilist=1,ishield_list(i)
2358            iresshield=shield_list(ilist,i)
2359            do k=1,3
2360            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2361      &      *2.0
2362            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2363      &              rlocshield
2364      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2365             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2366 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2367 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2368 C             if (iresshield.gt.i) then
2369 C               do ishi=i+1,iresshield-1
2370 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2371 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2372 C
2373 C              enddo
2374 C             else
2375 C               do ishi=iresshield,i
2376 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2377 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2378 C
2379 C               enddo
2380 C              endif
2381 C           enddo
2382 C          enddo
2383            enddo
2384           enddo
2385           do ilist=1,ishield_list(j)
2386            iresshield=shield_list(ilist,j)
2387            do k=1,3
2388            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2389      &     *2.0
2390            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2391      &              rlocshield
2392      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2393            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2394            enddo
2395           enddo
2396
2397           do k=1,3
2398             gshieldc(k,i)=gshieldc(k,i)+
2399      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2400             gshieldc(k,j)=gshieldc(k,j)+
2401      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2402             gshieldc(k,i-1)=gshieldc(k,i-1)+
2403      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2404             gshieldc(k,j-1)=gshieldc(k,j-1)+
2405      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2406
2407            enddo
2408            endif
2409
2410           do k=1,3
2411             ghalf=0.5D0*ggg(k)
2412             gelc(k,i)=gelc(k,i)+ghalf
2413             gelc(k,j)=gelc(k,j)+ghalf
2414           enddo
2415 *
2416 * Loop over residues i+1 thru j-1.
2417 *
2418           do k=i+1,j-1
2419             do l=1,3
2420               gelc(l,k)=gelc(l,k)+ggg(l)
2421             enddo
2422           enddo
2423 C          ggg(1)=facvdw*xj
2424 C          ggg(2)=facvdw*yj
2425 C          ggg(3)=facvdw*zj
2426           if (sss.gt.0.0) then
2427           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2428           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2429           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2430           else
2431           ggg(1)=0.0
2432           ggg(2)=0.0
2433           ggg(3)=0.0
2434           endif
2435           do k=1,3
2436             ghalf=0.5D0*ggg(k)
2437             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2438             gvdwpp(k,j)=gvdwpp(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               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2446             enddo
2447           enddo
2448 #else
2449           facvdw=(ev1+evdwij)*sss
2450           facel=el1+eesij
2451           fac1=fac
2452           fac=-3*rrmij*(facvdw+facvdw+facel)
2453           erij(1)=xj*rmij
2454           erij(2)=yj*rmij
2455           erij(3)=zj*rmij
2456           if (calc_grad) then
2457 *
2458 * Radial derivatives. First process both termini of the fragment (i,j)
2459 *
2460           ggg(1)=fac*xj
2461           ggg(2)=fac*yj
2462           ggg(3)=fac*zj
2463           do k=1,3
2464             ghalf=0.5D0*ggg(k)
2465             gelc(k,i)=gelc(k,i)+ghalf
2466             gelc(k,j)=gelc(k,j)+ghalf
2467           enddo
2468 *
2469 * Loop over residues i+1 thru j-1.
2470 *
2471           do k=i+1,j-1
2472             do l=1,3
2473               gelc(l,k)=gelc(l,k)+ggg(l)
2474             enddo
2475           enddo
2476 #endif
2477 *
2478 * Angular part
2479 *
2480           ecosa=2.0D0*fac3*fac1+fac4
2481           fac4=-3.0D0*fac4
2482           fac3=-6.0D0*fac3
2483           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2484           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2485           do k=1,3
2486             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2487             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2488           enddo
2489 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2490 cd   &          (dcosg(k),k=1,3)
2491           do k=1,3
2492             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2493      &      *fac_shield(i)**2*fac_shield(j)**2
2494           enddo
2495           do k=1,3
2496             ghalf=0.5D0*ggg(k)
2497             gelc(k,i)=gelc(k,i)+ghalf
2498      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2499      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2500      &           *fac_shield(i)**2*fac_shield(j)**2
2501
2502             gelc(k,j)=gelc(k,j)+ghalf
2503      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2504      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2505      &           *fac_shield(i)**2*fac_shield(j)**2
2506           enddo
2507           do k=i+1,j-1
2508             do l=1,3
2509               gelc(l,k)=gelc(l,k)+ggg(l)
2510             enddo
2511           enddo
2512           endif
2513
2514           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2515      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2516      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2517 C
2518 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2519 C   energy of a peptide unit is assumed in the form of a second-order
2520 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2521 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2522 C   are computed for EVERY pair of non-contiguous peptide groups.
2523 C
2524           if (j.lt.nres-1) then
2525             j1=j+1
2526             j2=j-1
2527           else
2528             j1=j-1
2529             j2=j-2
2530           endif
2531           kkk=0
2532           do k=1,2
2533             do l=1,2
2534               kkk=kkk+1
2535               muij(kkk)=mu(k,i)*mu(l,j)
2536             enddo
2537           enddo
2538 cd         write (iout,*) 'EELEC: i',i,' j',j
2539 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2540 cd          write(iout,*) 'muij',muij
2541           ury=scalar(uy(1,i),erij)
2542           urz=scalar(uz(1,i),erij)
2543           vry=scalar(uy(1,j),erij)
2544           vrz=scalar(uz(1,j),erij)
2545           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2546           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2547           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2548           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2549 C For diagnostics only
2550 cd          a22=1.0d0
2551 cd          a23=1.0d0
2552 cd          a32=1.0d0
2553 cd          a33=1.0d0
2554           fac=dsqrt(-ael6i)*r3ij
2555 cd          write (2,*) 'fac=',fac
2556 C For diagnostics only
2557 cd          fac=1.0d0
2558           a22=a22*fac
2559           a23=a23*fac
2560           a32=a32*fac
2561           a33=a33*fac
2562 cd          write (iout,'(4i5,4f10.5)')
2563 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2564 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2565 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2566 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2567 cd          write (iout,'(4f10.5)')
2568 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2569 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2570 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2571 cd           write (iout,'(2i3,9f10.5/)') i,j,
2572 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2573           if (calc_grad) then
2574 C Derivatives of the elements of A in virtual-bond vectors
2575           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2576 cd          do k=1,3
2577 cd            do l=1,3
2578 cd              erder(k,l)=0.0d0
2579 cd            enddo
2580 cd          enddo
2581           do k=1,3
2582             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2583             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2584             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2585             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2586             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2587             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2588             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2589             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2590             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2591             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2592             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2593             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2594           enddo
2595 cd          do k=1,3
2596 cd            do l=1,3
2597 cd              uryg(k,l)=0.0d0
2598 cd              urzg(k,l)=0.0d0
2599 cd              vryg(k,l)=0.0d0
2600 cd              vrzg(k,l)=0.0d0
2601 cd            enddo
2602 cd          enddo
2603 C Compute radial contributions to the gradient
2604           facr=-3.0d0*rrmij
2605           a22der=a22*facr
2606           a23der=a23*facr
2607           a32der=a32*facr
2608           a33der=a33*facr
2609 cd          a22der=0.0d0
2610 cd          a23der=0.0d0
2611 cd          a32der=0.0d0
2612 cd          a33der=0.0d0
2613           agg(1,1)=a22der*xj
2614           agg(2,1)=a22der*yj
2615           agg(3,1)=a22der*zj
2616           agg(1,2)=a23der*xj
2617           agg(2,2)=a23der*yj
2618           agg(3,2)=a23der*zj
2619           agg(1,3)=a32der*xj
2620           agg(2,3)=a32der*yj
2621           agg(3,3)=a32der*zj
2622           agg(1,4)=a33der*xj
2623           agg(2,4)=a33der*yj
2624           agg(3,4)=a33der*zj
2625 C Add the contributions coming from er
2626           fac3=-3.0d0*fac
2627           do k=1,3
2628             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2629             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2630             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2631             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2632           enddo
2633           do k=1,3
2634 C Derivatives in DC(i)
2635             ghalf1=0.5d0*agg(k,1)
2636             ghalf2=0.5d0*agg(k,2)
2637             ghalf3=0.5d0*agg(k,3)
2638             ghalf4=0.5d0*agg(k,4)
2639             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2640      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2641             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2642      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2643             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2644      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2645             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2646      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2647 C Derivatives in DC(i+1)
2648             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2649      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2650             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2651      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2652             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2653      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2654             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2655      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2656 C Derivatives in DC(j)
2657             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2658      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2659             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2660      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2661             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2662      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2663             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2664      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2665 C Derivatives in DC(j+1) or DC(nres-1)
2666             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2667      &      -3.0d0*vryg(k,3)*ury)
2668             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2669      &      -3.0d0*vrzg(k,3)*ury)
2670             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2671      &      -3.0d0*vryg(k,3)*urz)
2672             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2673      &      -3.0d0*vrzg(k,3)*urz)
2674 cd            aggi(k,1)=ghalf1
2675 cd            aggi(k,2)=ghalf2
2676 cd            aggi(k,3)=ghalf3
2677 cd            aggi(k,4)=ghalf4
2678 C Derivatives in DC(i+1)
2679 cd            aggi1(k,1)=agg(k,1)
2680 cd            aggi1(k,2)=agg(k,2)
2681 cd            aggi1(k,3)=agg(k,3)
2682 cd            aggi1(k,4)=agg(k,4)
2683 C Derivatives in DC(j)
2684 cd            aggj(k,1)=ghalf1
2685 cd            aggj(k,2)=ghalf2
2686 cd            aggj(k,3)=ghalf3
2687 cd            aggj(k,4)=ghalf4
2688 C Derivatives in DC(j+1)
2689 cd            aggj1(k,1)=0.0d0
2690 cd            aggj1(k,2)=0.0d0
2691 cd            aggj1(k,3)=0.0d0
2692 cd            aggj1(k,4)=0.0d0
2693             if (j.eq.nres-1 .and. i.lt.j-2) then
2694               do l=1,4
2695                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2696 cd                aggj1(k,l)=agg(k,l)
2697               enddo
2698             endif
2699           enddo
2700           endif
2701 c          goto 11111
2702 C Check the loc-el terms by numerical integration
2703           acipa(1,1)=a22
2704           acipa(1,2)=a23
2705           acipa(2,1)=a32
2706           acipa(2,2)=a33
2707           a22=-a22
2708           a23=-a23
2709           do l=1,2
2710             do k=1,3
2711               agg(k,l)=-agg(k,l)
2712               aggi(k,l)=-aggi(k,l)
2713               aggi1(k,l)=-aggi1(k,l)
2714               aggj(k,l)=-aggj(k,l)
2715               aggj1(k,l)=-aggj1(k,l)
2716             enddo
2717           enddo
2718           if (j.lt.nres-1) then
2719             a22=-a22
2720             a32=-a32
2721             do l=1,3,2
2722               do k=1,3
2723                 agg(k,l)=-agg(k,l)
2724                 aggi(k,l)=-aggi(k,l)
2725                 aggi1(k,l)=-aggi1(k,l)
2726                 aggj(k,l)=-aggj(k,l)
2727                 aggj1(k,l)=-aggj1(k,l)
2728               enddo
2729             enddo
2730           else
2731             a22=-a22
2732             a23=-a23
2733             a32=-a32
2734             a33=-a33
2735             do l=1,4
2736               do k=1,3
2737                 agg(k,l)=-agg(k,l)
2738                 aggi(k,l)=-aggi(k,l)
2739                 aggi1(k,l)=-aggi1(k,l)
2740                 aggj(k,l)=-aggj(k,l)
2741                 aggj1(k,l)=-aggj1(k,l)
2742               enddo
2743             enddo
2744           endif
2745           ENDIF ! WCORR
2746 11111     continue
2747           IF (wel_loc.gt.0.0d0) THEN
2748 C Contribution to the local-electrostatic energy coming from the i-j pair
2749           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2750      &     +a33*muij(4)
2751 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2752 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2753           if (shield_mode.eq.0) then
2754            fac_shield(i)=1.0
2755            fac_shield(j)=1.0
2756 C          else
2757 C           fac_shield(i)=0.4
2758 C           fac_shield(j)=0.6
2759           endif
2760           eel_loc_ij=eel_loc_ij
2761      &    *fac_shield(i)*fac_shield(j)
2762           eel_loc=eel_loc+eel_loc_ij
2763 C Partial derivatives in virtual-bond dihedral angles gamma
2764           if (calc_grad) then
2765           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2766      &  (shield_mode.gt.0)) then
2767 C          print *,i,j
2768
2769           do ilist=1,ishield_list(i)
2770            iresshield=shield_list(ilist,i)
2771            do k=1,3
2772            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2773      &                                          /fac_shield(i)
2774 C     &      *2.0
2775            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2776      &              rlocshield
2777      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2778             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2779      &      +rlocshield
2780            enddo
2781           enddo
2782           do ilist=1,ishield_list(j)
2783            iresshield=shield_list(ilist,j)
2784            do k=1,3
2785            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2786      &                                       /fac_shield(j)
2787 C     &     *2.0
2788            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2789      &              rlocshield
2790      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2791            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2792      &             +rlocshield
2793
2794            enddo
2795           enddo
2796           do k=1,3
2797             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2798      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2799             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2800      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2801             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2802      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2803             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2804      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2805            enddo
2806            endif
2807           if (i.gt.1)
2808      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2809      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2810      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2811      &    *fac_shield(i)*fac_shield(j)
2812           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2813      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2814      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2815      &    *fac_shield(i)*fac_shield(j)
2816
2817 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2818 cd          write(iout,*) 'agg  ',agg
2819 cd          write(iout,*) 'aggi ',aggi
2820 cd          write(iout,*) 'aggi1',aggi1
2821 cd          write(iout,*) 'aggj ',aggj
2822 cd          write(iout,*) 'aggj1',aggj1
2823
2824 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2825           do l=1,3
2826             ggg(l)=agg(l,1)*muij(1)+
2827      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2828      &    *fac_shield(i)*fac_shield(j)
2829
2830           enddo
2831           do k=i+2,j2
2832             do l=1,3
2833               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2834             enddo
2835           enddo
2836 C Remaining derivatives of eello
2837           do l=1,3
2838             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2839      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2840      &    *fac_shield(i)*fac_shield(j)
2841
2842             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2843      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2844      &    *fac_shield(i)*fac_shield(j)
2845
2846             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2847      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2848      &    *fac_shield(i)*fac_shield(j)
2849
2850             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2851      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2852      &    *fac_shield(i)*fac_shield(j)
2853
2854           enddo
2855           endif
2856           ENDIF
2857           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2858 C Contributions from turns
2859             a_temp(1,1)=a22
2860             a_temp(1,2)=a23
2861             a_temp(2,1)=a32
2862             a_temp(2,2)=a33
2863             call eturn34(i,j,eello_turn3,eello_turn4)
2864           endif
2865 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2866           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2867 C
2868 C Calculate the contact function. The ith column of the array JCONT will
2869 C contain the numbers of atoms that make contacts with the atom I (of numbers
2870 C greater than I). The arrays FACONT and GACONT will contain the values of
2871 C the contact function and its derivative.
2872 c           r0ij=1.02D0*rpp(iteli,itelj)
2873 c           r0ij=1.11D0*rpp(iteli,itelj)
2874             r0ij=2.20D0*rpp(iteli,itelj)
2875 c           r0ij=1.55D0*rpp(iteli,itelj)
2876             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2877             if (fcont.gt.0.0D0) then
2878               num_conti=num_conti+1
2879               if (num_conti.gt.maxconts) then
2880                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2881      &                         ' will skip next contacts for this conf.'
2882               else
2883                 jcont_hb(num_conti,i)=j
2884                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2885      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2886 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2887 C  terms.
2888                 d_cont(num_conti,i)=rij
2889 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2890 C     --- Electrostatic-interaction matrix ---
2891                 a_chuj(1,1,num_conti,i)=a22
2892                 a_chuj(1,2,num_conti,i)=a23
2893                 a_chuj(2,1,num_conti,i)=a32
2894                 a_chuj(2,2,num_conti,i)=a33
2895 C     --- Gradient of rij
2896                 do kkk=1,3
2897                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2898                 enddo
2899 c             if (i.eq.1) then
2900 c                a_chuj(1,1,num_conti,i)=-0.61d0
2901 c                a_chuj(1,2,num_conti,i)= 0.4d0
2902 c                a_chuj(2,1,num_conti,i)= 0.65d0
2903 c                a_chuj(2,2,num_conti,i)= 0.50d0
2904 c             else if (i.eq.2) then
2905 c                a_chuj(1,1,num_conti,i)= 0.0d0
2906 c                a_chuj(1,2,num_conti,i)= 0.0d0
2907 c                a_chuj(2,1,num_conti,i)= 0.0d0
2908 c                a_chuj(2,2,num_conti,i)= 0.0d0
2909 c             endif
2910 C     --- and its gradients
2911 cd                write (iout,*) 'i',i,' j',j
2912 cd                do kkk=1,3
2913 cd                write (iout,*) 'iii 1 kkk',kkk
2914 cd                write (iout,*) agg(kkk,:)
2915 cd                enddo
2916 cd                do kkk=1,3
2917 cd                write (iout,*) 'iii 2 kkk',kkk
2918 cd                write (iout,*) aggi(kkk,:)
2919 cd                enddo
2920 cd                do kkk=1,3
2921 cd                write (iout,*) 'iii 3 kkk',kkk
2922 cd                write (iout,*) aggi1(kkk,:)
2923 cd                enddo
2924 cd                do kkk=1,3
2925 cd                write (iout,*) 'iii 4 kkk',kkk
2926 cd                write (iout,*) aggj(kkk,:)
2927 cd                enddo
2928 cd                do kkk=1,3
2929 cd                write (iout,*) 'iii 5 kkk',kkk
2930 cd                write (iout,*) aggj1(kkk,:)
2931 cd                enddo
2932                 kkll=0
2933                 do k=1,2
2934                   do l=1,2
2935                     kkll=kkll+1
2936                     do m=1,3
2937                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2938                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2939                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2940                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2941                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2942 c                      do mm=1,5
2943 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2944 c                      enddo
2945                     enddo
2946                   enddo
2947                 enddo
2948                 ENDIF
2949                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2950 C Calculate contact energies
2951                 cosa4=4.0D0*cosa
2952                 wij=cosa-3.0D0*cosb*cosg
2953                 cosbg1=cosb+cosg
2954                 cosbg2=cosb-cosg
2955 c               fac3=dsqrt(-ael6i)/r0ij**3
2956                 fac3=dsqrt(-ael6i)*r3ij
2957                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2958                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2959                 if (shield_mode.eq.0) then
2960                 fac_shield(i)=1.0d0
2961                 fac_shield(j)=1.0d0
2962                 else
2963                 ees0plist(num_conti,i)=j
2964 C                fac_shield(i)=0.4d0
2965 C                fac_shield(j)=0.6d0
2966                 endif
2967 c               ees0mij=0.0D0
2968                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2969      &          *fac_shield(i)*fac_shield(j)
2970
2971                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2972      &          *fac_shield(i)*fac_shield(j)
2973
2974 C Diagnostics. Comment out or remove after debugging!
2975 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2976 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2977 c               ees0m(num_conti,i)=0.0D0
2978 C End diagnostics.
2979 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2980 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2981                 facont_hb(num_conti,i)=fcont
2982                 if (calc_grad) then
2983 C Angular derivatives of the contact function
2984                 ees0pij1=fac3/ees0pij
2985                 ees0mij1=fac3/ees0mij
2986                 fac3p=-3.0D0*fac3*rrmij
2987                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2988                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2989 c               ees0mij1=0.0D0
2990                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2991                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2992                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2993                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2994                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2995                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2996                 ecosap=ecosa1+ecosa2
2997                 ecosbp=ecosb1+ecosb2
2998                 ecosgp=ecosg1+ecosg2
2999                 ecosam=ecosa1-ecosa2
3000                 ecosbm=ecosb1-ecosb2
3001                 ecosgm=ecosg1-ecosg2
3002 C Diagnostics
3003 c               ecosap=ecosa1
3004 c               ecosbp=ecosb1
3005 c               ecosgp=ecosg1
3006 c               ecosam=0.0D0
3007 c               ecosbm=0.0D0
3008 c               ecosgm=0.0D0
3009 C End diagnostics
3010                 fprimcont=fprimcont/rij
3011 cd              facont_hb(num_conti,i)=1.0D0
3012 C Following line is for diagnostics.
3013 cd              fprimcont=0.0D0
3014                 do k=1,3
3015                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3016                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3017                 enddo
3018                 do k=1,3
3019                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3020                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3021                 enddo
3022                 gggp(1)=gggp(1)+ees0pijp*xj
3023                 gggp(2)=gggp(2)+ees0pijp*yj
3024                 gggp(3)=gggp(3)+ees0pijp*zj
3025                 gggm(1)=gggm(1)+ees0mijp*xj
3026                 gggm(2)=gggm(2)+ees0mijp*yj
3027                 gggm(3)=gggm(3)+ees0mijp*zj
3028 C Derivatives due to the contact function
3029                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3030                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3031                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3032                 do k=1,3
3033                   ghalfp=0.5D0*gggp(k)
3034                   ghalfm=0.5D0*gggm(k)
3035                   gacontp_hb1(k,num_conti,i)=ghalfp
3036      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3037      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3038      &          *fac_shield(i)*fac_shield(j)
3039
3040                   gacontp_hb2(k,num_conti,i)=ghalfp
3041      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3042      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3043      &          *fac_shield(i)*fac_shield(j)
3044
3045                   gacontp_hb3(k,num_conti,i)=gggp(k)
3046      &          *fac_shield(i)*fac_shield(j)
3047
3048                   gacontm_hb1(k,num_conti,i)=ghalfm
3049      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3050      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3051      &          *fac_shield(i)*fac_shield(j)
3052
3053                   gacontm_hb2(k,num_conti,i)=ghalfm
3054      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3055      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3056      &          *fac_shield(i)*fac_shield(j)
3057
3058                   gacontm_hb3(k,num_conti,i)=gggm(k)
3059      &          *fac_shield(i)*fac_shield(j)
3060
3061                 enddo
3062                 endif
3063 C Diagnostics. Comment out or remove after debugging!
3064 cdiag           do k=1,3
3065 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3066 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3067 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3068 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3069 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3070 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3071 cdiag           enddo
3072               ENDIF ! wcorr
3073               endif  ! num_conti.le.maxconts
3074             endif  ! fcont.gt.0
3075           endif    ! j.gt.i+1
3076  1216     continue
3077         enddo ! j
3078         num_cont_hb(i)=num_conti
3079  1215   continue
3080       enddo   ! i
3081 cd      do i=1,nres
3082 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3083 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3084 cd      enddo
3085 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3086 ccc      eel_loc=eel_loc+eello_turn3
3087       return
3088       end
3089 C-----------------------------------------------------------------------------
3090       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3091 C Third- and fourth-order contributions from turns
3092       implicit real*8 (a-h,o-z)
3093       include 'DIMENSIONS'
3094       include 'sizesclu.dat'
3095       include 'COMMON.IOUNITS'
3096       include 'COMMON.GEO'
3097       include 'COMMON.VAR'
3098       include 'COMMON.LOCAL'
3099       include 'COMMON.CHAIN'
3100       include 'COMMON.DERIV'
3101       include 'COMMON.INTERACT'
3102       include 'COMMON.CONTACTS'
3103       include 'COMMON.TORSION'
3104       include 'COMMON.VECTORS'
3105       include 'COMMON.FFIELD'
3106       include 'COMMON.SHIELD'
3107       include 'COMMON.CONTROL'
3108
3109       dimension ggg(3)
3110       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3111      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3112      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3113       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3114      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3115       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3116       if (j.eq.i+2) then
3117       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3118 C changes suggested by Ana to avoid out of bounds
3119 C     & .or.((i+5).gt.nres)
3120 C     & .or.((i-1).le.0)
3121 C end of changes suggested by Ana
3122      &    .or. itype(i+2).eq.ntyp1
3123      &    .or. itype(i+3).eq.ntyp1
3124 C     &    .or. itype(i+5).eq.ntyp1
3125 C     &    .or. itype(i).eq.ntyp1
3126 C     &    .or. itype(i-1).eq.ntyp1
3127      &    ) goto 179
3128
3129 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3130 C
3131 C               Third-order contributions
3132 C
3133 C                 (i+2)o----(i+3)
3134 C                      | |
3135 C                      | |
3136 C                 (i+1)o----i
3137 C
3138 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3139 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3140         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3141         call transpose2(auxmat(1,1),auxmat1(1,1))
3142         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3143         if (shield_mode.eq.0) then
3144         fac_shield(i)=1.0
3145         fac_shield(j)=1.0
3146 C        else
3147 C        fac_shield(i)=0.4
3148 C        fac_shield(j)=0.6
3149         endif
3150         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3151      &  *fac_shield(i)*fac_shield(j)
3152         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3153      &  *fac_shield(i)*fac_shield(j)
3154
3155 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3156 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3157 cd     &    ' eello_turn3_num',4*eello_turn3_num
3158         if (calc_grad) then
3159 C Derivatives in shield mode
3160           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3161      &  (shield_mode.gt.0)) then
3162 C          print *,i,j
3163
3164           do ilist=1,ishield_list(i)
3165            iresshield=shield_list(ilist,i)
3166            do k=1,3
3167            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3168 C     &      *2.0
3169            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3170      &              rlocshield
3171      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3172             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3173      &      +rlocshield
3174            enddo
3175           enddo
3176           do ilist=1,ishield_list(j)
3177            iresshield=shield_list(ilist,j)
3178            do k=1,3
3179            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3180 C     &     *2.0
3181            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3182      &              rlocshield
3183      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3184            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3185      &             +rlocshield
3186
3187            enddo
3188           enddo
3189
3190           do k=1,3
3191             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3192      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3193             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3194      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3195             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3196      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3197             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3198      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3199            enddo
3200            endif
3201
3202 C Derivatives in gamma(i)
3203         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3204         call transpose2(auxmat2(1,1),pizda(1,1))
3205         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3206         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3207      &   *fac_shield(i)*fac_shield(j)
3208
3209 C Derivatives in gamma(i+1)
3210         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3211         call transpose2(auxmat2(1,1),pizda(1,1))
3212         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3213         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3214      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3215      &   *fac_shield(i)*fac_shield(j)
3216
3217 C Cartesian derivatives
3218         do l=1,3
3219           a_temp(1,1)=aggi(l,1)
3220           a_temp(1,2)=aggi(l,2)
3221           a_temp(2,1)=aggi(l,3)
3222           a_temp(2,2)=aggi(l,4)
3223           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3224           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3225      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3226      &   *fac_shield(i)*fac_shield(j)
3227
3228           a_temp(1,1)=aggi1(l,1)
3229           a_temp(1,2)=aggi1(l,2)
3230           a_temp(2,1)=aggi1(l,3)
3231           a_temp(2,2)=aggi1(l,4)
3232           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3233           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3234      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3235      &   *fac_shield(i)*fac_shield(j)
3236
3237           a_temp(1,1)=aggj(l,1)
3238           a_temp(1,2)=aggj(l,2)
3239           a_temp(2,1)=aggj(l,3)
3240           a_temp(2,2)=aggj(l,4)
3241           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3242           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3243      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3244      &   *fac_shield(i)*fac_shield(j)
3245
3246           a_temp(1,1)=aggj1(l,1)
3247           a_temp(1,2)=aggj1(l,2)
3248           a_temp(2,1)=aggj1(l,3)
3249           a_temp(2,2)=aggj1(l,4)
3250           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3251           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3252      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3253      &   *fac_shield(i)*fac_shield(j)
3254
3255         enddo
3256         endif
3257   179 continue
3258       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3259       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3260 C changes suggested by Ana to avoid out of bounds
3261 C     & .or.((i+5).gt.nres)
3262 C     & .or.((i-1).le.0)
3263 C end of changes suggested by Ana
3264      &    .or. itype(i+3).eq.ntyp1
3265      &    .or. itype(i+4).eq.ntyp1
3266 C     &    .or. itype(i+5).eq.ntyp1
3267      &    .or. itype(i).eq.ntyp1
3268 C     &    .or. itype(i-1).eq.ntyp1
3269      &    ) goto 178
3270
3271 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3272 C
3273 C               Fourth-order contributions
3274 C
3275 C                 (i+3)o----(i+4)
3276 C                     /  |
3277 C               (i+2)o   |
3278 C                     \  |
3279 C                 (i+1)o----i
3280 C
3281 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3282 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3283         iti1=itortyp(itype(i+1))
3284         iti2=itortyp(itype(i+2))
3285         iti3=itortyp(itype(i+3))
3286         call transpose2(EUg(1,1,i+1),e1t(1,1))
3287         call transpose2(Eug(1,1,i+2),e2t(1,1))
3288         call transpose2(Eug(1,1,i+3),e3t(1,1))
3289         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3290         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3291         s1=scalar2(b1(1,iti2),auxvec(1))
3292         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3293         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3294         s2=scalar2(b1(1,iti1),auxvec(1))
3295         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3296         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3297         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3298         if (shield_mode.eq.0) then
3299         fac_shield(i)=1.0
3300         fac_shield(j)=1.0
3301 C        else
3302 C        fac_shield(i)=0.4
3303 C        fac_shield(j)=0.6
3304         endif
3305         eello_turn4=eello_turn4-(s1+s2+s3)
3306      &  *fac_shield(i)*fac_shield(j)
3307         eello_t4=-(s1+s2+s3)
3308      &  *fac_shield(i)*fac_shield(j)
3309
3310 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3311 cd     &    ' eello_turn4_num',8*eello_turn4_num
3312 C Derivatives in gamma(i)
3313         if (calc_grad) then
3314           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3315      &  (shield_mode.gt.0)) then
3316 C          print *,i,j
3317
3318           do ilist=1,ishield_list(i)
3319            iresshield=shield_list(ilist,i)
3320            do k=1,3
3321            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3322 C     &      *2.0
3323            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3324      &              rlocshield
3325      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3326             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3327      &      +rlocshield
3328            enddo
3329           enddo
3330           do ilist=1,ishield_list(j)
3331            iresshield=shield_list(ilist,j)
3332            do k=1,3
3333            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3334 C     &     *2.0
3335            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3336      &              rlocshield
3337      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3338            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3339      &             +rlocshield
3340
3341            enddo
3342           enddo
3343
3344           do k=1,3
3345             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3346      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3347             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3348      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3349             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3350      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3351             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3352      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3353            enddo
3354            endif
3355
3356         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3357         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3358         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3359         s1=scalar2(b1(1,iti2),auxvec(1))
3360         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3361         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3362         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3363      &  *fac_shield(i)*fac_shield(j)
3364
3365 C Derivatives in gamma(i+1)
3366         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3367         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3368         s2=scalar2(b1(1,iti1),auxvec(1))
3369         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3370         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3371         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3372         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3373      &  *fac_shield(i)*fac_shield(j)
3374
3375 C Derivatives in gamma(i+2)
3376         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3377         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3378         s1=scalar2(b1(1,iti2),auxvec(1))
3379         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3380         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3381         s2=scalar2(b1(1,iti1),auxvec(1))
3382         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3383         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3384         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3385         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3386      &  *fac_shield(i)*fac_shield(j)
3387
3388 C Cartesian derivatives
3389 C Derivatives of this turn contributions in DC(i+2)
3390         if (j.lt.nres-1) then
3391           do l=1,3
3392             a_temp(1,1)=agg(l,1)
3393             a_temp(1,2)=agg(l,2)
3394             a_temp(2,1)=agg(l,3)
3395             a_temp(2,2)=agg(l,4)
3396             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3397             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3398             s1=scalar2(b1(1,iti2),auxvec(1))
3399             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3400             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3401             s2=scalar2(b1(1,iti1),auxvec(1))
3402             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3403             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3404             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3405             ggg(l)=-(s1+s2+s3)
3406             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3407      &  *fac_shield(i)*fac_shield(j)
3408
3409           enddo
3410         endif
3411 C Remaining derivatives of this turn contribution
3412         do l=1,3
3413           a_temp(1,1)=aggi(l,1)
3414           a_temp(1,2)=aggi(l,2)
3415           a_temp(2,1)=aggi(l,3)
3416           a_temp(2,2)=aggi(l,4)
3417           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3418           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3419           s1=scalar2(b1(1,iti2),auxvec(1))
3420           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3421           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3422           s2=scalar2(b1(1,iti1),auxvec(1))
3423           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3424           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3425           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3426           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3427      &  *fac_shield(i)*fac_shield(j)
3428
3429           a_temp(1,1)=aggi1(l,1)
3430           a_temp(1,2)=aggi1(l,2)
3431           a_temp(2,1)=aggi1(l,3)
3432           a_temp(2,2)=aggi1(l,4)
3433           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3434           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3435           s1=scalar2(b1(1,iti2),auxvec(1))
3436           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3437           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3438           s2=scalar2(b1(1,iti1),auxvec(1))
3439           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3440           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3441           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3442           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3443      &  *fac_shield(i)*fac_shield(j)
3444
3445           a_temp(1,1)=aggj(l,1)
3446           a_temp(1,2)=aggj(l,2)
3447           a_temp(2,1)=aggj(l,3)
3448           a_temp(2,2)=aggj(l,4)
3449           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3450           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3451           s1=scalar2(b1(1,iti2),auxvec(1))
3452           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3453           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3454           s2=scalar2(b1(1,iti1),auxvec(1))
3455           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3456           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3457           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3458           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3459      &  *fac_shield(i)*fac_shield(j)
3460
3461           a_temp(1,1)=aggj1(l,1)
3462           a_temp(1,2)=aggj1(l,2)
3463           a_temp(2,1)=aggj1(l,3)
3464           a_temp(2,2)=aggj1(l,4)
3465           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3466           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3467           s1=scalar2(b1(1,iti2),auxvec(1))
3468           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3469           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3470           s2=scalar2(b1(1,iti1),auxvec(1))
3471           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3472           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3473           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3474           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3475      &  *fac_shield(i)*fac_shield(j)
3476
3477         enddo
3478         endif
3479   178 continue
3480       endif
3481       return
3482       end
3483 C-----------------------------------------------------------------------------
3484       subroutine vecpr(u,v,w)
3485       implicit real*8(a-h,o-z)
3486       dimension u(3),v(3),w(3)
3487       w(1)=u(2)*v(3)-u(3)*v(2)
3488       w(2)=-u(1)*v(3)+u(3)*v(1)
3489       w(3)=u(1)*v(2)-u(2)*v(1)
3490       return
3491       end
3492 C-----------------------------------------------------------------------------
3493       subroutine unormderiv(u,ugrad,unorm,ungrad)
3494 C This subroutine computes the derivatives of a normalized vector u, given
3495 C the derivatives computed without normalization conditions, ugrad. Returns
3496 C ungrad.
3497       implicit none
3498       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3499       double precision vec(3)
3500       double precision scalar
3501       integer i,j
3502 c      write (2,*) 'ugrad',ugrad
3503 c      write (2,*) 'u',u
3504       do i=1,3
3505         vec(i)=scalar(ugrad(1,i),u(1))
3506       enddo
3507 c      write (2,*) 'vec',vec
3508       do i=1,3
3509         do j=1,3
3510           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3511         enddo
3512       enddo
3513 c      write (2,*) 'ungrad',ungrad
3514       return
3515       end
3516 C-----------------------------------------------------------------------------
3517       subroutine escp(evdw2,evdw2_14)
3518 C
3519 C This subroutine calculates the excluded-volume interaction energy between
3520 C peptide-group centers and side chains and its gradient in virtual-bond and
3521 C side-chain vectors.
3522 C
3523       implicit real*8 (a-h,o-z)
3524       include 'DIMENSIONS'
3525       include 'sizesclu.dat'
3526       include 'COMMON.GEO'
3527       include 'COMMON.VAR'
3528       include 'COMMON.LOCAL'
3529       include 'COMMON.CHAIN'
3530       include 'COMMON.DERIV'
3531       include 'COMMON.INTERACT'
3532       include 'COMMON.FFIELD'
3533       include 'COMMON.IOUNITS'
3534       dimension ggg(3)
3535       evdw2=0.0D0
3536       evdw2_14=0.0d0
3537 cd    print '(a)','Enter ESCP'
3538 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3539 c     &  ' scal14',scal14
3540       do i=iatscp_s,iatscp_e
3541         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3542         iteli=itel(i)
3543 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3544 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3545         if (iteli.eq.0) goto 1225
3546         xi=0.5D0*(c(1,i)+c(1,i+1))
3547         yi=0.5D0*(c(2,i)+c(2,i+1))
3548         zi=0.5D0*(c(3,i)+c(3,i+1))
3549 C    Returning the ith atom to box
3550           xi=mod(xi,boxxsize)
3551           if (xi.lt.0) xi=xi+boxxsize
3552           yi=mod(yi,boxysize)
3553           if (yi.lt.0) yi=yi+boxysize
3554           zi=mod(zi,boxzsize)
3555           if (zi.lt.0) zi=zi+boxzsize
3556
3557         do iint=1,nscp_gr(i)
3558
3559         do j=iscpstart(i,iint),iscpend(i,iint)
3560           itypj=iabs(itype(j))
3561           if (itypj.eq.ntyp1) cycle
3562 C Uncomment following three lines for SC-p interactions
3563 c         xj=c(1,nres+j)-xi
3564 c         yj=c(2,nres+j)-yi
3565 c         zj=c(3,nres+j)-zi
3566 C Uncomment following three lines for Ca-p interactions
3567           xj=c(1,j)
3568           yj=c(2,j)
3569           zj=c(3,j)
3570 C returning the jth atom to box
3571           xj=mod(xj,boxxsize)
3572           if (xj.lt.0) xj=xj+boxxsize
3573           yj=mod(yj,boxysize)
3574           if (yj.lt.0) yj=yj+boxysize
3575           zj=mod(zj,boxzsize)
3576           if (zj.lt.0) zj=zj+boxzsize
3577       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3578       xj_safe=xj
3579       yj_safe=yj
3580       zj_safe=zj
3581       subchap=0
3582 C Finding the closest jth atom
3583       do xshift=-1,1
3584       do yshift=-1,1
3585       do zshift=-1,1
3586           xj=xj_safe+xshift*boxxsize
3587           yj=yj_safe+yshift*boxysize
3588           zj=zj_safe+zshift*boxzsize
3589           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3590           if(dist_temp.lt.dist_init) then
3591             dist_init=dist_temp
3592             xj_temp=xj
3593             yj_temp=yj
3594             zj_temp=zj
3595             subchap=1
3596           endif
3597        enddo
3598        enddo
3599        enddo
3600        if (subchap.eq.1) then
3601           xj=xj_temp-xi
3602           yj=yj_temp-yi
3603           zj=zj_temp-zi
3604        else
3605           xj=xj_safe-xi
3606           yj=yj_safe-yi
3607           zj=zj_safe-zi
3608        endif
3609
3610           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3611 C sss is scaling function for smoothing the cutoff gradient otherwise
3612 C the gradient would not be continuouse
3613           sss=sscale(1.0d0/(dsqrt(rrij)))
3614           if (sss.le.0.0d0) cycle
3615           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3616           fac=rrij**expon2
3617           e1=fac*fac*aad(itypj,iteli)
3618           e2=fac*bad(itypj,iteli)
3619           if (iabs(j-i) .le. 2) then
3620             e1=scal14*e1
3621             e2=scal14*e2
3622             evdw2_14=evdw2_14+(e1+e2)*sss
3623           endif
3624           evdwij=e1+e2
3625 c          write (iout,*) i,j,evdwij
3626           evdw2=evdw2+evdwij*sss
3627           if (calc_grad) then
3628 C
3629 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3630 C
3631            fac=-(evdwij+e1)*rrij*sss
3632            fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3633           ggg(1)=xj*fac
3634           ggg(2)=yj*fac
3635           ggg(3)=zj*fac
3636           if (j.lt.i) then
3637 cd          write (iout,*) 'j<i'
3638 C Uncomment following three lines for SC-p interactions
3639 c           do k=1,3
3640 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3641 c           enddo
3642           else
3643 cd          write (iout,*) 'j>i'
3644             do k=1,3
3645               ggg(k)=-ggg(k)
3646 C Uncomment following line for SC-p interactions
3647 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3648             enddo
3649           endif
3650           do k=1,3
3651             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3652           enddo
3653           kstart=min0(i+1,j)
3654           kend=max0(i-1,j-1)
3655 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3656 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3657           do k=kstart,kend
3658             do l=1,3
3659               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3660             enddo
3661           enddo
3662           endif
3663         enddo
3664         enddo ! iint
3665  1225   continue
3666       enddo ! i
3667       do i=1,nct
3668         do j=1,3
3669           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3670           gradx_scp(j,i)=expon*gradx_scp(j,i)
3671         enddo
3672       enddo
3673 C******************************************************************************
3674 C
3675 C                              N O T E !!!
3676 C
3677 C To save time the factor EXPON has been extracted from ALL components
3678 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3679 C use!
3680 C
3681 C******************************************************************************
3682       return
3683       end
3684 C--------------------------------------------------------------------------
3685       subroutine edis(ehpb)
3686 C
3687 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3688 C
3689       implicit real*8 (a-h,o-z)
3690       include 'DIMENSIONS'
3691       include 'sizesclu.dat'
3692       include 'COMMON.SBRIDGE'
3693       include 'COMMON.CHAIN'
3694       include 'COMMON.DERIV'
3695       include 'COMMON.VAR'
3696       include 'COMMON.INTERACT'
3697       include 'COMMON.CONTROL'
3698       dimension ggg(3)
3699       ehpb=0.0D0
3700 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3701 cd    print *,'link_start=',link_start,' link_end=',link_end
3702       if (link_end.eq.0) return
3703       do i=link_start,link_end
3704 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3705 C CA-CA distance used in regularization of structure.
3706         ii=ihpb(i)
3707         jj=jhpb(i)
3708 C iii and jjj point to the residues for which the distance is assigned.
3709         if (ii.gt.nres) then
3710           iii=ii-nres
3711           jjj=jj-nres
3712         else
3713           iii=ii
3714           jjj=jj
3715         endif
3716 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3717 C    distance and angle dependent SS bond potential.
3718 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3719 C     &  iabs(itype(jjj)).eq.1) then
3720 C          call ssbond_ene(iii,jjj,eij)
3721 C          ehpb=ehpb+2*eij
3722 C        else
3723        if (.not.dyn_ss .and. i.le.nss) then
3724          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3725      & iabs(itype(jjj)).eq.1) then
3726           call ssbond_ene(iii,jjj,eij)
3727           ehpb=ehpb+2*eij
3728            endif !ii.gt.neres
3729         else if (ii.gt.nres .and. jj.gt.nres) then
3730 c Restraints from contact prediction
3731           dd=dist(ii,jj)
3732           if (constr_dist.eq.11) then
3733 C            ehpb=ehpb+fordepth(i)**4.0d0
3734 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3735             ehpb=ehpb+fordepth(i)**4.0d0
3736      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3737             fac=fordepth(i)**4.0d0
3738      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3739 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3740 C     &    ehpb,fordepth(i),dd
3741 C             print *,"TUTU"
3742 C            write(iout,*) ehpb,"atu?"
3743 C            ehpb,"tu?"
3744 C            fac=fordepth(i)**4.0d0
3745 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3746            else !constr_dist.eq.11
3747           if (dhpb1(i).gt.0.0d0) then
3748             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3749             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3750 c            write (iout,*) "beta nmr",
3751 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3752           else !dhpb(i).gt.0.00
3753
3754 C Calculate the distance between the two points and its difference from the
3755 C target distance.
3756         dd=dist(ii,jj)
3757         rdis=dd-dhpb(i)
3758 C Get the force constant corresponding to this distance.
3759         waga=forcon(i)
3760 C Calculate the contribution to energy.
3761         ehpb=ehpb+waga*rdis*rdis
3762 C
3763 C Evaluate gradient.
3764 C
3765         fac=waga*rdis/dd
3766         endif !dhpb(i).gt.0
3767         endif
3768 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3769 cd   &   ' waga=',waga,' fac=',fac
3770         do j=1,3
3771           ggg(j)=fac*(c(j,jj)-c(j,ii))
3772         enddo
3773 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3774 C If this is a SC-SC distance, we need to calculate the contributions to the
3775 C Cartesian gradient in the SC vectors (ghpbx).
3776         if (iii.lt.ii) then
3777           do j=1,3
3778             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3779             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3780           enddo
3781         endif
3782         else !ii.gt.nres
3783 C          write(iout,*) "before"
3784           dd=dist(ii,jj)
3785 C          write(iout,*) "after",dd
3786           if (constr_dist.eq.11) then
3787             ehpb=ehpb+fordepth(i)**4.0d0
3788      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3789             fac=fordepth(i)**4.0d0
3790      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3791 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3792 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3793 C            print *,ehpb,"tu?"
3794 C            write(iout,*) ehpb,"btu?",
3795 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3796 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3797 C     &    ehpb,fordepth(i),dd
3798            else
3799           if (dhpb1(i).gt.0.0d0) then
3800             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3801             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3802 c            write (iout,*) "alph nmr",
3803 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3804           else
3805             rdis=dd-dhpb(i)
3806 C Get the force constant corresponding to this distance.
3807             waga=forcon(i)
3808 C Calculate the contribution to energy.
3809             ehpb=ehpb+waga*rdis*rdis
3810 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3811 C
3812 C Evaluate gradient.
3813 C
3814             fac=waga*rdis/dd
3815           endif
3816           endif
3817         do j=1,3
3818           ggg(j)=fac*(c(j,jj)-c(j,ii))
3819         enddo
3820 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3821 C If this is a SC-SC distance, we need to calculate the contributions to the
3822 C Cartesian gradient in the SC vectors (ghpbx).
3823         if (iii.lt.ii) then
3824           do j=1,3
3825             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3826             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3827           enddo
3828         endif
3829         do j=iii,jjj-1
3830           do k=1,3
3831             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3832           enddo
3833         enddo
3834         endif
3835       enddo
3836       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3837       return
3838       end
3839 C--------------------------------------------------------------------------
3840       subroutine ssbond_ene(i,j,eij)
3841 C
3842 C Calculate the distance and angle dependent SS-bond potential energy
3843 C using a free-energy function derived based on RHF/6-31G** ab initio
3844 C calculations of diethyl disulfide.
3845 C
3846 C A. Liwo and U. Kozlowska, 11/24/03
3847 C
3848       implicit real*8 (a-h,o-z)
3849       include 'DIMENSIONS'
3850       include 'sizesclu.dat'
3851       include 'COMMON.SBRIDGE'
3852       include 'COMMON.CHAIN'
3853       include 'COMMON.DERIV'
3854       include 'COMMON.LOCAL'
3855       include 'COMMON.INTERACT'
3856       include 'COMMON.VAR'
3857       include 'COMMON.IOUNITS'
3858       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3859       itypi=iabs(itype(i))
3860       xi=c(1,nres+i)
3861       yi=c(2,nres+i)
3862       zi=c(3,nres+i)
3863       dxi=dc_norm(1,nres+i)
3864       dyi=dc_norm(2,nres+i)
3865       dzi=dc_norm(3,nres+i)
3866       dsci_inv=dsc_inv(itypi)
3867       itypj=iabs(itype(j))
3868       dscj_inv=dsc_inv(itypj)
3869       xj=c(1,nres+j)-xi
3870       yj=c(2,nres+j)-yi
3871       zj=c(3,nres+j)-zi
3872       dxj=dc_norm(1,nres+j)
3873       dyj=dc_norm(2,nres+j)
3874       dzj=dc_norm(3,nres+j)
3875       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3876       rij=dsqrt(rrij)
3877       erij(1)=xj*rij
3878       erij(2)=yj*rij
3879       erij(3)=zj*rij
3880       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3881       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3882       om12=dxi*dxj+dyi*dyj+dzi*dzj
3883       do k=1,3
3884         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3885         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3886       enddo
3887       rij=1.0d0/rij
3888       deltad=rij-d0cm
3889       deltat1=1.0d0-om1
3890       deltat2=1.0d0+om2
3891       deltat12=om2-om1+2.0d0
3892       cosphi=om12-om1*om2
3893       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3894      &  +akct*deltad*deltat12
3895      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3896 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3897 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3898 c     &  " deltat12",deltat12," eij",eij
3899       ed=2*akcm*deltad+akct*deltat12
3900       pom1=akct*deltad
3901       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3902       eom1=-2*akth*deltat1-pom1-om2*pom2
3903       eom2= 2*akth*deltat2+pom1-om1*pom2
3904       eom12=pom2
3905       do k=1,3
3906         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3907       enddo
3908       do k=1,3
3909         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3910      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3911         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3912      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3913       enddo
3914 C
3915 C Calculate the components of the gradient in DC and X
3916 C
3917       do k=i,j-1
3918         do l=1,3
3919           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3920         enddo
3921       enddo
3922       return
3923       end
3924 C--------------------------------------------------------------------------
3925       subroutine ebond(estr)
3926 c
3927 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3928 c
3929       implicit real*8 (a-h,o-z)
3930       include 'DIMENSIONS'
3931       include 'sizesclu.dat'
3932       include 'COMMON.LOCAL'
3933       include 'COMMON.GEO'
3934       include 'COMMON.INTERACT'
3935       include 'COMMON.DERIV'
3936       include 'COMMON.VAR'
3937       include 'COMMON.CHAIN'
3938       include 'COMMON.IOUNITS'
3939       include 'COMMON.NAMES'
3940       include 'COMMON.FFIELD'
3941       include 'COMMON.CONTROL'
3942       logical energy_dec /.false./
3943       double precision u(3),ud(3)
3944       estr=0.0d0
3945       estr1=0.0d0
3946       do i=nnt+1,nct
3947         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3948 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3949 C          do j=1,3
3950 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3951 C     &      *dc(j,i-1)/vbld(i)
3952 C          enddo
3953 C          if (energy_dec) write(iout,*)
3954 C     &       "estr1",i,vbld(i),distchainmax,
3955 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3956 C        else
3957          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3958         diff = vbld(i)-vbldpDUM
3959          else
3960           diff = vbld(i)-vbldp0
3961 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3962          endif
3963           estr=estr+diff*diff
3964           do j=1,3
3965             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3966           enddo
3967 C        endif
3968 C        write (iout,'(a7,i5,4f7.3)')
3969 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3970       enddo
3971       estr=0.5d0*AKP*estr+estr1
3972 c
3973 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3974 c
3975       do i=nnt,nct
3976         iti=iabs(itype(i))
3977         if (iti.ne.10 .and. iti.ne.ntyp1) then
3978           nbi=nbondterm(iti)
3979           if (nbi.eq.1) then
3980             diff=vbld(i+nres)-vbldsc0(1,iti)
3981 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3982 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3983             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3984             do j=1,3
3985               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3986             enddo
3987           else
3988             do j=1,nbi
3989               diff=vbld(i+nres)-vbldsc0(j,iti)
3990               ud(j)=aksc(j,iti)*diff
3991               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3992             enddo
3993             uprod=u(1)
3994             do j=2,nbi
3995               uprod=uprod*u(j)
3996             enddo
3997             usum=0.0d0
3998             usumsqder=0.0d0
3999             do j=1,nbi
4000               uprod1=1.0d0
4001               uprod2=1.0d0
4002               do k=1,nbi
4003                 if (k.ne.j) then
4004                   uprod1=uprod1*u(k)
4005                   uprod2=uprod2*u(k)*u(k)
4006                 endif
4007               enddo
4008               usum=usum+uprod1
4009               usumsqder=usumsqder+ud(j)*uprod2
4010             enddo
4011 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4012 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4013             estr=estr+uprod/usum
4014             do j=1,3
4015              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4016             enddo
4017           endif
4018         endif
4019       enddo
4020       return
4021       end
4022 #ifdef CRYST_THETA
4023 C--------------------------------------------------------------------------
4024       subroutine ebend(etheta,ethetacnstr)
4025 C
4026 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4027 C angles gamma and its derivatives in consecutive thetas and gammas.
4028 C
4029       implicit real*8 (a-h,o-z)
4030       include 'DIMENSIONS'
4031       include 'sizesclu.dat'
4032       include 'COMMON.LOCAL'
4033       include 'COMMON.GEO'
4034       include 'COMMON.INTERACT'
4035       include 'COMMON.DERIV'
4036       include 'COMMON.VAR'
4037       include 'COMMON.CHAIN'
4038       include 'COMMON.IOUNITS'
4039       include 'COMMON.NAMES'
4040       include 'COMMON.FFIELD'
4041       include 'COMMON.TORCNSTR'
4042       common /calcthet/ term1,term2,termm,diffak,ratak,
4043      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4044      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4045       double precision y(2),z(2)
4046       delta=0.02d0*pi
4047 c      time11=dexp(-2*time)
4048 c      time12=1.0d0
4049       etheta=0.0D0
4050 c      write (iout,*) "nres",nres
4051 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4052 c      write (iout,*) ithet_start,ithet_end
4053       do i=ithet_start,ithet_end
4054         if (i.le.2) cycle
4055         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4056      &  .or.itype(i).eq.ntyp1) cycle
4057 C Zero the energy function and its derivative at 0 or pi.
4058         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4059         it=itype(i-1)
4060         ichir1=isign(1,itype(i-2))
4061         ichir2=isign(1,itype(i))
4062          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4063          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4064          if (itype(i-1).eq.10) then
4065           itype1=isign(10,itype(i-2))
4066           ichir11=isign(1,itype(i-2))
4067           ichir12=isign(1,itype(i-2))
4068           itype2=isign(10,itype(i))
4069           ichir21=isign(1,itype(i))
4070           ichir22=isign(1,itype(i))
4071          endif
4072          if (i.eq.3) then
4073           y(1)=0.0D0
4074           y(2)=0.0D0
4075           else
4076         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4077 #ifdef OSF
4078           phii=phi(i)
4079 c          icrc=0
4080 c          call proc_proc(phii,icrc)
4081           if (icrc.eq.1) phii=150.0
4082 #else
4083           phii=phi(i)
4084 #endif
4085           y(1)=dcos(phii)
4086           y(2)=dsin(phii)
4087         else
4088           y(1)=0.0D0
4089           y(2)=0.0D0
4090         endif
4091         endif
4092         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4093 #ifdef OSF
4094           phii1=phi(i+1)
4095 c          icrc=0
4096 c          call proc_proc(phii1,icrc)
4097           if (icrc.eq.1) phii1=150.0
4098           phii1=pinorm(phii1)
4099           z(1)=cos(phii1)
4100 #else
4101           phii1=phi(i+1)
4102           z(1)=dcos(phii1)
4103 #endif
4104           z(2)=dsin(phii1)
4105         else
4106           z(1)=0.0D0
4107           z(2)=0.0D0
4108         endif
4109 C Calculate the "mean" value of theta from the part of the distribution
4110 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4111 C In following comments this theta will be referred to as t_c.
4112         thet_pred_mean=0.0d0
4113         do k=1,2
4114             athetk=athet(k,it,ichir1,ichir2)
4115             bthetk=bthet(k,it,ichir1,ichir2)
4116           if (it.eq.10) then
4117              athetk=athet(k,itype1,ichir11,ichir12)
4118              bthetk=bthet(k,itype2,ichir21,ichir22)
4119           endif
4120           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4121         enddo
4122 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4123         dthett=thet_pred_mean*ssd
4124         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4125 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4126 C Derivatives of the "mean" values in gamma1 and gamma2.
4127         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4128      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4129          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4130      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4131          if (it.eq.10) then
4132       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4133      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4134         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4135      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4136          endif
4137         if (theta(i).gt.pi-delta) then
4138           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4139      &         E_tc0)
4140           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4141           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4142           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4143      &        E_theta)
4144           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4145      &        E_tc)
4146         else if (theta(i).lt.delta) then
4147           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4148           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4149           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4150      &        E_theta)
4151           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4152           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4153      &        E_tc)
4154         else
4155           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4156      &        E_theta,E_tc)
4157         endif
4158         etheta=etheta+ethetai
4159 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4160 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4161         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4162         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4163         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4164 c 1215   continue
4165       enddo
4166 C Ufff.... We've done all this!!!
4167 C now constrains
4168       ethetacnstr=0.0d0
4169 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4170       do i=1,ntheta_constr
4171         itheta=itheta_constr(i)
4172         thetiii=theta(itheta)
4173         difi=pinorm(thetiii-theta_constr0(i))
4174         if (difi.gt.theta_drange(i)) then
4175           difi=difi-theta_drange(i)
4176           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4177           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4178      &    +for_thet_constr(i)*difi**3
4179         else if (difi.lt.-drange(i)) then
4180           difi=difi+drange(i)
4181           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4182           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4183      &    +for_thet_constr(i)*difi**3
4184         else
4185           difi=0.0
4186         endif
4187 C       if (energy_dec) then
4188 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4189 C     &    i,itheta,rad2deg*thetiii,
4190 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4191 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4192 C     &    gloc(itheta+nphi-2,icg)
4193 C        endif
4194       enddo
4195       return
4196       end
4197 C---------------------------------------------------------------------------
4198       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4199      &     E_tc)
4200       implicit real*8 (a-h,o-z)
4201       include 'DIMENSIONS'
4202       include 'COMMON.LOCAL'
4203       include 'COMMON.IOUNITS'
4204       common /calcthet/ term1,term2,termm,diffak,ratak,
4205      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4206      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4207 C Calculate the contributions to both Gaussian lobes.
4208 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4209 C The "polynomial part" of the "standard deviation" of this part of
4210 C the distribution.
4211         sig=polthet(3,it)
4212         do j=2,0,-1
4213           sig=sig*thet_pred_mean+polthet(j,it)
4214         enddo
4215 C Derivative of the "interior part" of the "standard deviation of the"
4216 C gamma-dependent Gaussian lobe in t_c.
4217         sigtc=3*polthet(3,it)
4218         do j=2,1,-1
4219           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4220         enddo
4221         sigtc=sig*sigtc
4222 C Set the parameters of both Gaussian lobes of the distribution.
4223 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4224         fac=sig*sig+sigc0(it)
4225         sigcsq=fac+fac
4226         sigc=1.0D0/sigcsq
4227 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4228         sigsqtc=-4.0D0*sigcsq*sigtc
4229 c       print *,i,sig,sigtc,sigsqtc
4230 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4231         sigtc=-sigtc/(fac*fac)
4232 C Following variable is sigma(t_c)**(-2)
4233         sigcsq=sigcsq*sigcsq
4234         sig0i=sig0(it)
4235         sig0inv=1.0D0/sig0i**2
4236         delthec=thetai-thet_pred_mean
4237         delthe0=thetai-theta0i
4238         term1=-0.5D0*sigcsq*delthec*delthec
4239         term2=-0.5D0*sig0inv*delthe0*delthe0
4240 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4241 C NaNs in taking the logarithm. We extract the largest exponent which is added
4242 C to the energy (this being the log of the distribution) at the end of energy
4243 C term evaluation for this virtual-bond angle.
4244         if (term1.gt.term2) then
4245           termm=term1
4246           term2=dexp(term2-termm)
4247           term1=1.0d0
4248         else
4249           termm=term2
4250           term1=dexp(term1-termm)
4251           term2=1.0d0
4252         endif
4253 C The ratio between the gamma-independent and gamma-dependent lobes of
4254 C the distribution is a Gaussian function of thet_pred_mean too.
4255         diffak=gthet(2,it)-thet_pred_mean
4256         ratak=diffak/gthet(3,it)**2
4257         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4258 C Let's differentiate it in thet_pred_mean NOW.
4259         aktc=ak*ratak
4260 C Now put together the distribution terms to make complete distribution.
4261         termexp=term1+ak*term2
4262         termpre=sigc+ak*sig0i
4263 C Contribution of the bending energy from this theta is just the -log of
4264 C the sum of the contributions from the two lobes and the pre-exponential
4265 C factor. Simple enough, isn't it?
4266         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4267 C NOW the derivatives!!!
4268 C 6/6/97 Take into account the deformation.
4269         E_theta=(delthec*sigcsq*term1
4270      &       +ak*delthe0*sig0inv*term2)/termexp
4271         E_tc=((sigtc+aktc*sig0i)/termpre
4272      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4273      &       aktc*term2)/termexp)
4274       return
4275       end
4276 c-----------------------------------------------------------------------------
4277       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4278       implicit real*8 (a-h,o-z)
4279       include 'DIMENSIONS'
4280       include 'COMMON.LOCAL'
4281       include 'COMMON.IOUNITS'
4282       common /calcthet/ term1,term2,termm,diffak,ratak,
4283      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4284      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4285       delthec=thetai-thet_pred_mean
4286       delthe0=thetai-theta0i
4287 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4288       t3 = thetai-thet_pred_mean
4289       t6 = t3**2
4290       t9 = term1
4291       t12 = t3*sigcsq
4292       t14 = t12+t6*sigsqtc
4293       t16 = 1.0d0
4294       t21 = thetai-theta0i
4295       t23 = t21**2
4296       t26 = term2
4297       t27 = t21*t26
4298       t32 = termexp
4299       t40 = t32**2
4300       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4301      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4302      & *(-t12*t9-ak*sig0inv*t27)
4303       return
4304       end
4305 #else
4306 C--------------------------------------------------------------------------
4307       subroutine ebend(etheta,ethetacnstr)
4308 C
4309 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4310 C angles gamma and its derivatives in consecutive thetas and gammas.
4311 C ab initio-derived potentials from
4312 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4313 C
4314       implicit real*8 (a-h,o-z)
4315       include 'DIMENSIONS'
4316       include 'sizesclu.dat'
4317       include 'COMMON.LOCAL'
4318       include 'COMMON.GEO'
4319       include 'COMMON.INTERACT'
4320       include 'COMMON.DERIV'
4321       include 'COMMON.VAR'
4322       include 'COMMON.CHAIN'
4323       include 'COMMON.IOUNITS'
4324       include 'COMMON.NAMES'
4325       include 'COMMON.FFIELD'
4326       include 'COMMON.CONTROL'
4327       include 'COMMON.TORCNSTR'
4328       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4329      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4330      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4331      & sinph1ph2(maxdouble,maxdouble)
4332       logical lprn /.false./, lprn1 /.false./
4333       etheta=0.0D0
4334 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4335       do i=ithet_start,ithet_end
4336         if (i.le.2) cycle
4337         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4338      &  .or.itype(i).eq.ntyp1) cycle
4339 c        if (itype(i-1).eq.ntyp1) cycle
4340         if (iabs(itype(i+1)).eq.20) iblock=2
4341         if (iabs(itype(i+1)).ne.20) iblock=1
4342         dethetai=0.0d0
4343         dephii=0.0d0
4344         dephii1=0.0d0
4345         theti2=0.5d0*theta(i)
4346         ityp2=ithetyp((itype(i-1)))
4347         do k=1,nntheterm
4348           coskt(k)=dcos(k*theti2)
4349           sinkt(k)=dsin(k*theti2)
4350         enddo
4351         if (i.eq.3) then
4352           phii=0.0d0
4353           ityp1=nthetyp+1
4354           do k=1,nsingle
4355             cosph1(k)=0.0d0
4356             sinph1(k)=0.0d0
4357           enddo
4358         else
4359         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4360 #ifdef OSF
4361           phii=phi(i)
4362           if (phii.ne.phii) phii=150.0
4363 #else
4364           phii=phi(i)
4365 #endif
4366           ityp1=ithetyp((itype(i-2)))
4367           do k=1,nsingle
4368             cosph1(k)=dcos(k*phii)
4369             sinph1(k)=dsin(k*phii)
4370           enddo
4371         else
4372           phii=0.0d0
4373 c          ityp1=nthetyp+1
4374           do k=1,nsingle
4375             ityp1=ithetyp((itype(i-2)))
4376             cosph1(k)=0.0d0
4377             sinph1(k)=0.0d0
4378           enddo
4379         endif
4380         endif
4381         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4382 #ifdef OSF
4383           phii1=phi(i+1)
4384           if (phii1.ne.phii1) phii1=150.0
4385           phii1=pinorm(phii1)
4386 #else
4387           phii1=phi(i+1)
4388 #endif
4389           ityp3=ithetyp((itype(i)))
4390           do k=1,nsingle
4391             cosph2(k)=dcos(k*phii1)
4392             sinph2(k)=dsin(k*phii1)
4393           enddo
4394         else
4395           phii1=0.0d0
4396 c          ityp3=nthetyp+1
4397           ityp3=ithetyp((itype(i)))
4398           do k=1,nsingle
4399             cosph2(k)=0.0d0
4400             sinph2(k)=0.0d0
4401           enddo
4402         endif
4403 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4404 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4405 c        call flush(iout)
4406         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4407         do k=1,ndouble
4408           do l=1,k-1
4409             ccl=cosph1(l)*cosph2(k-l)
4410             ssl=sinph1(l)*sinph2(k-l)
4411             scl=sinph1(l)*cosph2(k-l)
4412             csl=cosph1(l)*sinph2(k-l)
4413             cosph1ph2(l,k)=ccl-ssl
4414             cosph1ph2(k,l)=ccl+ssl
4415             sinph1ph2(l,k)=scl+csl
4416             sinph1ph2(k,l)=scl-csl
4417           enddo
4418         enddo
4419         if (lprn) then
4420         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4421      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4422         write (iout,*) "coskt and sinkt"
4423         do k=1,nntheterm
4424           write (iout,*) k,coskt(k),sinkt(k)
4425         enddo
4426         endif
4427         do k=1,ntheterm
4428           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4429           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4430      &      *coskt(k)
4431           if (lprn)
4432      &    write (iout,*) "k",k," aathet",
4433      &    aathet(k,ityp1,ityp2,ityp3,iblock),
4434      &     " ethetai",ethetai
4435         enddo
4436         if (lprn) then
4437         write (iout,*) "cosph and sinph"
4438         do k=1,nsingle
4439           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4440         enddo
4441         write (iout,*) "cosph1ph2 and sinph2ph2"
4442         do k=2,ndouble
4443           do l=1,k-1
4444             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4445      &         sinph1ph2(l,k),sinph1ph2(k,l)
4446           enddo
4447         enddo
4448         write(iout,*) "ethetai",ethetai
4449         endif
4450         do m=1,ntheterm2
4451           do k=1,nsingle
4452             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4453      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4454      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4455      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4456             ethetai=ethetai+sinkt(m)*aux
4457             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4458             dephii=dephii+k*sinkt(m)*(
4459      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4460      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4461             dephii1=dephii1+k*sinkt(m)*(
4462      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4463      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4464             if (lprn)
4465      &      write (iout,*) "m",m," k",k," bbthet",
4466      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4467      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4468      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4469      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4470           enddo
4471         enddo
4472         if (lprn)
4473      &  write(iout,*) "ethetai",ethetai
4474         do m=1,ntheterm3
4475           do k=2,ndouble
4476             do l=1,k-1
4477               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4478      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4479      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4480      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4481               ethetai=ethetai+sinkt(m)*aux
4482               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4483               dephii=dephii+l*sinkt(m)*(
4484      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4485      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4486      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4487      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4488               dephii1=dephii1+(k-l)*sinkt(m)*(
4489      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4490      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4491      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4492      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4493               if (lprn) then
4494               write (iout,*) "m",m," k",k," l",l," ffthet",
4495      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4496      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4497      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4498      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4499      &            " ethetai",ethetai
4500               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4501      &            cosph1ph2(k,l)*sinkt(m),
4502      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4503               endif
4504             enddo
4505           enddo
4506         enddo
4507 10      continue
4508         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4509      &   i,theta(i)*rad2deg,phii*rad2deg,
4510      &   phii1*rad2deg,ethetai
4511         etheta=etheta+ethetai
4512         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4513         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4514 c        gloc(nphi+i-2,icg)=wang*dethetai
4515         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4516       enddo
4517 C now constrains
4518       ethetacnstr=0.0d0
4519 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4520       do i=1,ntheta_constr
4521         itheta=itheta_constr(i)
4522         thetiii=theta(itheta)
4523         difi=pinorm(thetiii-theta_constr0(i))
4524         if (difi.gt.theta_drange(i)) then
4525           difi=difi-theta_drange(i)
4526           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4527           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4528      &    +for_thet_constr(i)*difi**3
4529         else if (difi.lt.-drange(i)) then
4530           difi=difi+drange(i)
4531           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4532           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4533      &    +for_thet_constr(i)*difi**3
4534         else
4535           difi=0.0
4536         endif
4537 C       if (energy_dec) then
4538 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4539 C     &    i,itheta,rad2deg*thetiii,
4540 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4541 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4542 C     &    gloc(itheta+nphi-2,icg)
4543 C        endif
4544       enddo
4545       return
4546       end
4547 #endif
4548 #ifdef CRYST_SC
4549 c-----------------------------------------------------------------------------
4550       subroutine esc(escloc)
4551 C Calculate the local energy of a side chain and its derivatives in the
4552 C corresponding virtual-bond valence angles THETA and the spherical angles
4553 C ALPHA and OMEGA.
4554       implicit real*8 (a-h,o-z)
4555       include 'DIMENSIONS'
4556       include 'sizesclu.dat'
4557       include 'COMMON.GEO'
4558       include 'COMMON.LOCAL'
4559       include 'COMMON.VAR'
4560       include 'COMMON.INTERACT'
4561       include 'COMMON.DERIV'
4562       include 'COMMON.CHAIN'
4563       include 'COMMON.IOUNITS'
4564       include 'COMMON.NAMES'
4565       include 'COMMON.FFIELD'
4566       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4567      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4568       common /sccalc/ time11,time12,time112,theti,it,nlobit
4569       delta=0.02d0*pi
4570       escloc=0.0D0
4571 c     write (iout,'(a)') 'ESC'
4572       do i=loc_start,loc_end
4573         it=itype(i)
4574         if (it.eq.ntyp1) cycle
4575         if (it.eq.10) goto 1
4576         nlobit=nlob(iabs(it))
4577 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4578 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4579         theti=theta(i+1)-pipol
4580         x(1)=dtan(theti)
4581         x(2)=alph(i)
4582         x(3)=omeg(i)
4583 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4584
4585         if (x(2).gt.pi-delta) then
4586           xtemp(1)=x(1)
4587           xtemp(2)=pi-delta
4588           xtemp(3)=x(3)
4589           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4590           xtemp(2)=pi
4591           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4592           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4593      &        escloci,dersc(2))
4594           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4595      &        ddersc0(1),dersc(1))
4596           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4597      &        ddersc0(3),dersc(3))
4598           xtemp(2)=pi-delta
4599           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4600           xtemp(2)=pi
4601           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4602           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4603      &            dersc0(2),esclocbi,dersc02)
4604           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4605      &            dersc12,dersc01)
4606           call splinthet(x(2),0.5d0*delta,ss,ssd)
4607           dersc0(1)=dersc01
4608           dersc0(2)=dersc02
4609           dersc0(3)=0.0d0
4610           do k=1,3
4611             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4612           enddo
4613           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4614 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4615 c    &             esclocbi,ss,ssd
4616           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4617 c         escloci=esclocbi
4618 c         write (iout,*) escloci
4619         else if (x(2).lt.delta) then
4620           xtemp(1)=x(1)
4621           xtemp(2)=delta
4622           xtemp(3)=x(3)
4623           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4624           xtemp(2)=0.0d0
4625           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4626           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4627      &        escloci,dersc(2))
4628           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4629      &        ddersc0(1),dersc(1))
4630           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4631      &        ddersc0(3),dersc(3))
4632           xtemp(2)=delta
4633           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4634           xtemp(2)=0.0d0
4635           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4636           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4637      &            dersc0(2),esclocbi,dersc02)
4638           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4639      &            dersc12,dersc01)
4640           dersc0(1)=dersc01
4641           dersc0(2)=dersc02
4642           dersc0(3)=0.0d0
4643           call splinthet(x(2),0.5d0*delta,ss,ssd)
4644           do k=1,3
4645             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4646           enddo
4647           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4648 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4649 c    &             esclocbi,ss,ssd
4650           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4651 c         write (iout,*) escloci
4652         else
4653           call enesc(x,escloci,dersc,ddummy,.false.)
4654         endif
4655
4656         escloc=escloc+escloci
4657 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4658
4659         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4660      &   wscloc*dersc(1)
4661         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4662         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4663     1   continue
4664       enddo
4665       return
4666       end
4667 C---------------------------------------------------------------------------
4668       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4669       implicit real*8 (a-h,o-z)
4670       include 'DIMENSIONS'
4671       include 'COMMON.GEO'
4672       include 'COMMON.LOCAL'
4673       include 'COMMON.IOUNITS'
4674       common /sccalc/ time11,time12,time112,theti,it,nlobit
4675       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4676       double precision contr(maxlob,-1:1)
4677       logical mixed
4678 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4679         escloc_i=0.0D0
4680         do j=1,3
4681           dersc(j)=0.0D0
4682           if (mixed) ddersc(j)=0.0d0
4683         enddo
4684         x3=x(3)
4685
4686 C Because of periodicity of the dependence of the SC energy in omega we have
4687 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4688 C To avoid underflows, first compute & store the exponents.
4689
4690         do iii=-1,1
4691
4692           x(3)=x3+iii*dwapi
4693
4694           do j=1,nlobit
4695             do k=1,3
4696               z(k)=x(k)-censc(k,j,it)
4697             enddo
4698             do k=1,3
4699               Axk=0.0D0
4700               do l=1,3
4701                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4702               enddo
4703               Ax(k,j,iii)=Axk
4704             enddo
4705             expfac=0.0D0
4706             do k=1,3
4707               expfac=expfac+Ax(k,j,iii)*z(k)
4708             enddo
4709             contr(j,iii)=expfac
4710           enddo ! j
4711
4712         enddo ! iii
4713
4714         x(3)=x3
4715 C As in the case of ebend, we want to avoid underflows in exponentiation and
4716 C subsequent NaNs and INFs in energy calculation.
4717 C Find the largest exponent
4718         emin=contr(1,-1)
4719         do iii=-1,1
4720           do j=1,nlobit
4721             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4722           enddo
4723         enddo
4724         emin=0.5D0*emin
4725 cd      print *,'it=',it,' emin=',emin
4726
4727 C Compute the contribution to SC energy and derivatives
4728         do iii=-1,1
4729
4730           do j=1,nlobit
4731             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4732 cd          print *,'j=',j,' expfac=',expfac
4733             escloc_i=escloc_i+expfac
4734             do k=1,3
4735               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4736             enddo
4737             if (mixed) then
4738               do k=1,3,2
4739                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4740      &            +gaussc(k,2,j,it))*expfac
4741               enddo
4742             endif
4743           enddo
4744
4745         enddo ! iii
4746
4747         dersc(1)=dersc(1)/cos(theti)**2
4748         ddersc(1)=ddersc(1)/cos(theti)**2
4749         ddersc(3)=ddersc(3)
4750
4751         escloci=-(dlog(escloc_i)-emin)
4752         do j=1,3
4753           dersc(j)=dersc(j)/escloc_i
4754         enddo
4755         if (mixed) then
4756           do j=1,3,2
4757             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4758           enddo
4759         endif
4760       return
4761       end
4762 C------------------------------------------------------------------------------
4763       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4764       implicit real*8 (a-h,o-z)
4765       include 'DIMENSIONS'
4766       include 'COMMON.GEO'
4767       include 'COMMON.LOCAL'
4768       include 'COMMON.IOUNITS'
4769       common /sccalc/ time11,time12,time112,theti,it,nlobit
4770       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4771       double precision contr(maxlob)
4772       logical mixed
4773
4774       escloc_i=0.0D0
4775
4776       do j=1,3
4777         dersc(j)=0.0D0
4778       enddo
4779
4780       do j=1,nlobit
4781         do k=1,2
4782           z(k)=x(k)-censc(k,j,it)
4783         enddo
4784         z(3)=dwapi
4785         do k=1,3
4786           Axk=0.0D0
4787           do l=1,3
4788             Axk=Axk+gaussc(l,k,j,it)*z(l)
4789           enddo
4790           Ax(k,j)=Axk
4791         enddo
4792         expfac=0.0D0
4793         do k=1,3
4794           expfac=expfac+Ax(k,j)*z(k)
4795         enddo
4796         contr(j)=expfac
4797       enddo ! j
4798
4799 C As in the case of ebend, we want to avoid underflows in exponentiation and
4800 C subsequent NaNs and INFs in energy calculation.
4801 C Find the largest exponent
4802       emin=contr(1)
4803       do j=1,nlobit
4804         if (emin.gt.contr(j)) emin=contr(j)
4805       enddo
4806       emin=0.5D0*emin
4807
4808 C Compute the contribution to SC energy and derivatives
4809
4810       dersc12=0.0d0
4811       do j=1,nlobit
4812         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4813         escloc_i=escloc_i+expfac
4814         do k=1,2
4815           dersc(k)=dersc(k)+Ax(k,j)*expfac
4816         enddo
4817         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4818      &            +gaussc(1,2,j,it))*expfac
4819         dersc(3)=0.0d0
4820       enddo
4821
4822       dersc(1)=dersc(1)/cos(theti)**2
4823       dersc12=dersc12/cos(theti)**2
4824       escloci=-(dlog(escloc_i)-emin)
4825       do j=1,2
4826         dersc(j)=dersc(j)/escloc_i
4827       enddo
4828       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4829       return
4830       end
4831 #else
4832 c----------------------------------------------------------------------------------
4833       subroutine esc(escloc)
4834 C Calculate the local energy of a side chain and its derivatives in the
4835 C corresponding virtual-bond valence angles THETA and the spherical angles
4836 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4837 C added by Urszula Kozlowska. 07/11/2007
4838 C
4839       implicit real*8 (a-h,o-z)
4840       include 'DIMENSIONS'
4841       include 'sizesclu.dat'
4842       include 'COMMON.GEO'
4843       include 'COMMON.LOCAL'
4844       include 'COMMON.VAR'
4845       include 'COMMON.SCROT'
4846       include 'COMMON.INTERACT'
4847       include 'COMMON.DERIV'
4848       include 'COMMON.CHAIN'
4849       include 'COMMON.IOUNITS'
4850       include 'COMMON.NAMES'
4851       include 'COMMON.FFIELD'
4852       include 'COMMON.CONTROL'
4853       include 'COMMON.VECTORS'
4854       double precision x_prime(3),y_prime(3),z_prime(3)
4855      &    , sumene,dsc_i,dp2_i,x(65),
4856      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4857      &    de_dxx,de_dyy,de_dzz,de_dt
4858       double precision s1_t,s1_6_t,s2_t,s2_6_t
4859       double precision
4860      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4861      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4862      & dt_dCi(3),dt_dCi1(3)
4863       common /sccalc/ time11,time12,time112,theti,it,nlobit
4864       delta=0.02d0*pi
4865       escloc=0.0D0
4866       do i=loc_start,loc_end
4867         if (itype(i).eq.ntyp1) cycle
4868         costtab(i+1) =dcos(theta(i+1))
4869         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4870         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4871         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4872         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4873         cosfac=dsqrt(cosfac2)
4874         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4875         sinfac=dsqrt(sinfac2)
4876         it=iabs(itype(i))
4877         if (it.eq.10) goto 1
4878 c
4879 C  Compute the axes of tghe local cartesian coordinates system; store in
4880 c   x_prime, y_prime and z_prime
4881 c
4882         do j=1,3
4883           x_prime(j) = 0.00
4884           y_prime(j) = 0.00
4885           z_prime(j) = 0.00
4886         enddo
4887 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4888 C     &   dc_norm(3,i+nres)
4889         do j = 1,3
4890           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4891           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4892         enddo
4893         do j = 1,3
4894           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4895         enddo
4896 c       write (2,*) "i",i
4897 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4898 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4899 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4900 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4901 c      & " xy",scalar(x_prime(1),y_prime(1)),
4902 c      & " xz",scalar(x_prime(1),z_prime(1)),
4903 c      & " yy",scalar(y_prime(1),y_prime(1)),
4904 c      & " yz",scalar(y_prime(1),z_prime(1)),
4905 c      & " zz",scalar(z_prime(1),z_prime(1))
4906 c
4907 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4908 C to local coordinate system. Store in xx, yy, zz.
4909 c
4910         xx=0.0d0
4911         yy=0.0d0
4912         zz=0.0d0
4913         do j = 1,3
4914           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4915           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4916           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4917         enddo
4918
4919         xxtab(i)=xx
4920         yytab(i)=yy
4921         zztab(i)=zz
4922 C
4923 C Compute the energy of the ith side cbain
4924 C
4925 c        write (2,*) "xx",xx," yy",yy," zz",zz
4926         it=iabs(itype(i))
4927         do j = 1,65
4928           x(j) = sc_parmin(j,it)
4929         enddo
4930 #ifdef CHECK_COORD
4931 Cc diagnostics - remove later
4932         xx1 = dcos(alph(2))
4933         yy1 = dsin(alph(2))*dcos(omeg(2))
4934 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
4935         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4936         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4937      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4938      &    xx1,yy1,zz1
4939 C,"  --- ", xx_w,yy_w,zz_w
4940 c end diagnostics
4941 #endif
4942         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4943      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4944      &   + x(10)*yy*zz
4945         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4946      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4947      & + x(20)*yy*zz
4948         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4949      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4950      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4951      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4952      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4953      &  +x(40)*xx*yy*zz
4954         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4955      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4956      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4957      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4958      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4959      &  +x(60)*xx*yy*zz
4960         dsc_i   = 0.743d0+x(61)
4961         dp2_i   = 1.9d0+x(62)
4962         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4963      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4964         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4965      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4966         s1=(1+x(63))/(0.1d0 + dscp1)
4967         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4968         s2=(1+x(65))/(0.1d0 + dscp2)
4969         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4970         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4971      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4972 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4973 c     &   sumene4,
4974 c     &   dscp1,dscp2,sumene
4975 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4976         escloc = escloc + sumene
4977 c        write (2,*) "escloc",escloc
4978         if (.not. calc_grad) goto 1
4979 #ifdef DEBUG
4980 C
4981 C This section to check the numerical derivatives of the energy of ith side
4982 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4983 C #define DEBUG in the code to turn it on.
4984 C
4985         write (2,*) "sumene               =",sumene
4986         aincr=1.0d-7
4987         xxsave=xx
4988         xx=xx+aincr
4989         write (2,*) xx,yy,zz
4990         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4991         de_dxx_num=(sumenep-sumene)/aincr
4992         xx=xxsave
4993         write (2,*) "xx+ sumene from enesc=",sumenep
4994         yysave=yy
4995         yy=yy+aincr
4996         write (2,*) xx,yy,zz
4997         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4998         de_dyy_num=(sumenep-sumene)/aincr
4999         yy=yysave
5000         write (2,*) "yy+ sumene from enesc=",sumenep
5001         zzsave=zz
5002         zz=zz+aincr
5003         write (2,*) xx,yy,zz
5004         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5005         de_dzz_num=(sumenep-sumene)/aincr
5006         zz=zzsave
5007         write (2,*) "zz+ sumene from enesc=",sumenep
5008         costsave=cost2tab(i+1)
5009         sintsave=sint2tab(i+1)
5010         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5011         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5012         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5013         de_dt_num=(sumenep-sumene)/aincr
5014         write (2,*) " t+ sumene from enesc=",sumenep
5015         cost2tab(i+1)=costsave
5016         sint2tab(i+1)=sintsave
5017 C End of diagnostics section.
5018 #endif
5019 C
5020 C Compute the gradient of esc
5021 C
5022         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5023         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5024         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5025         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5026         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5027         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5028         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5029         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5030         pom1=(sumene3*sint2tab(i+1)+sumene1)
5031      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5032         pom2=(sumene4*cost2tab(i+1)+sumene2)
5033      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5034         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5035         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5036      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5037      &  +x(40)*yy*zz
5038         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5039         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5040      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5041      &  +x(60)*yy*zz
5042         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5043      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5044      &        +(pom1+pom2)*pom_dx
5045 #ifdef DEBUG
5046         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5047 #endif
5048 C
5049         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5050         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5051      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5052      &  +x(40)*xx*zz
5053         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5054         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5055      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5056      &  +x(59)*zz**2 +x(60)*xx*zz
5057         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5058      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5059      &        +(pom1-pom2)*pom_dy
5060 #ifdef DEBUG
5061         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5062 #endif
5063 C
5064         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5065      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5066      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5067      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5068      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5069      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5070      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5071      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5072 #ifdef DEBUG
5073         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5074 #endif
5075 C
5076         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5077      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5078      &  +pom1*pom_dt1+pom2*pom_dt2
5079 #ifdef DEBUG
5080         write(2,*), "de_dt = ", de_dt,de_dt_num
5081 #endif
5082 c
5083 C
5084        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5085        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5086        cosfac2xx=cosfac2*xx
5087        sinfac2yy=sinfac2*yy
5088        do k = 1,3
5089          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5090      &      vbld_inv(i+1)
5091          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5092      &      vbld_inv(i)
5093          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5094          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5095 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5096 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5097 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5098 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5099          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5100          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5101          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5102          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5103          dZZ_Ci1(k)=0.0d0
5104          dZZ_Ci(k)=0.0d0
5105          do j=1,3
5106            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5107      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5108            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5109      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5110          enddo
5111
5112          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5113          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5114          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5115 c
5116          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5117          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5118        enddo
5119
5120        do k=1,3
5121          dXX_Ctab(k,i)=dXX_Ci(k)
5122          dXX_C1tab(k,i)=dXX_Ci1(k)
5123          dYY_Ctab(k,i)=dYY_Ci(k)
5124          dYY_C1tab(k,i)=dYY_Ci1(k)
5125          dZZ_Ctab(k,i)=dZZ_Ci(k)
5126          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5127          dXX_XYZtab(k,i)=dXX_XYZ(k)
5128          dYY_XYZtab(k,i)=dYY_XYZ(k)
5129          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5130        enddo
5131
5132        do k = 1,3
5133 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5134 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5135 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5136 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5137 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5138 c     &    dt_dci(k)
5139 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5140 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5141          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5142      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5143          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5144      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5145          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5146      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5147        enddo
5148 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5149 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5150
5151 C to check gradient call subroutine check_grad
5152
5153     1 continue
5154       enddo
5155       return
5156       end
5157 #endif
5158 c------------------------------------------------------------------------------
5159       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5160 C
5161 C This procedure calculates two-body contact function g(rij) and its derivative:
5162 C
5163 C           eps0ij                                     !       x < -1
5164 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5165 C            0                                         !       x > 1
5166 C
5167 C where x=(rij-r0ij)/delta
5168 C
5169 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5170 C
5171       implicit none
5172       double precision rij,r0ij,eps0ij,fcont,fprimcont
5173       double precision x,x2,x4,delta
5174 c     delta=0.02D0*r0ij
5175 c      delta=0.2D0*r0ij
5176       x=(rij-r0ij)/delta
5177       if (x.lt.-1.0D0) then
5178         fcont=eps0ij
5179         fprimcont=0.0D0
5180       else if (x.le.1.0D0) then
5181         x2=x*x
5182         x4=x2*x2
5183         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5184         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5185       else
5186         fcont=0.0D0
5187         fprimcont=0.0D0
5188       endif
5189       return
5190       end
5191 c------------------------------------------------------------------------------
5192       subroutine splinthet(theti,delta,ss,ssder)
5193       implicit real*8 (a-h,o-z)
5194       include 'DIMENSIONS'
5195       include 'sizesclu.dat'
5196       include 'COMMON.VAR'
5197       include 'COMMON.GEO'
5198       thetup=pi-delta
5199       thetlow=delta
5200       if (theti.gt.pipol) then
5201         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5202       else
5203         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5204         ssder=-ssder
5205       endif
5206       return
5207       end
5208 c------------------------------------------------------------------------------
5209       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5210       implicit none
5211       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5212       double precision ksi,ksi2,ksi3,a1,a2,a3
5213       a1=fprim0*delta/(f1-f0)
5214       a2=3.0d0-2.0d0*a1
5215       a3=a1-2.0d0
5216       ksi=(x-x0)/delta
5217       ksi2=ksi*ksi
5218       ksi3=ksi2*ksi
5219       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5220       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5221       return
5222       end
5223 c------------------------------------------------------------------------------
5224       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5225       implicit none
5226       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5227       double precision ksi,ksi2,ksi3,a1,a2,a3
5228       ksi=(x-x0)/delta
5229       ksi2=ksi*ksi
5230       ksi3=ksi2*ksi
5231       a1=fprim0x*delta
5232       a2=3*(f1x-f0x)-2*fprim0x*delta
5233       a3=fprim0x*delta-2*(f1x-f0x)
5234       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5235       return
5236       end
5237 C-----------------------------------------------------------------------------
5238 #ifdef CRYST_TOR
5239 C-----------------------------------------------------------------------------
5240       subroutine etor(etors,edihcnstr,fact)
5241       implicit real*8 (a-h,o-z)
5242       include 'DIMENSIONS'
5243       include 'sizesclu.dat'
5244       include 'COMMON.VAR'
5245       include 'COMMON.GEO'
5246       include 'COMMON.LOCAL'
5247       include 'COMMON.TORSION'
5248       include 'COMMON.INTERACT'
5249       include 'COMMON.DERIV'
5250       include 'COMMON.CHAIN'
5251       include 'COMMON.NAMES'
5252       include 'COMMON.IOUNITS'
5253       include 'COMMON.FFIELD'
5254       include 'COMMON.TORCNSTR'
5255       logical lprn
5256 C Set lprn=.true. for debugging
5257       lprn=.false.
5258 c      lprn=.true.
5259       etors=0.0D0
5260       do i=iphi_start,iphi_end
5261         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5262      &      .or. itype(i).eq.ntyp1) cycle
5263         itori=itortyp(itype(i-2))
5264         itori1=itortyp(itype(i-1))
5265         phii=phi(i)
5266         gloci=0.0D0
5267 C Proline-Proline pair is a special case...
5268         if (itori.eq.3 .and. itori1.eq.3) then
5269           if (phii.gt.-dwapi3) then
5270             cosphi=dcos(3*phii)
5271             fac=1.0D0/(1.0D0-cosphi)
5272             etorsi=v1(1,3,3)*fac
5273             etorsi=etorsi+etorsi
5274             etors=etors+etorsi-v1(1,3,3)
5275             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5276           endif
5277           do j=1,3
5278             v1ij=v1(j+1,itori,itori1)
5279             v2ij=v2(j+1,itori,itori1)
5280             cosphi=dcos(j*phii)
5281             sinphi=dsin(j*phii)
5282             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5283             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5284           enddo
5285         else
5286           do j=1,nterm_old
5287             v1ij=v1(j,itori,itori1)
5288             v2ij=v2(j,itori,itori1)
5289             cosphi=dcos(j*phii)
5290             sinphi=dsin(j*phii)
5291             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5292             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5293           enddo
5294         endif
5295         if (lprn)
5296      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5297      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5298      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5299         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5300 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5301       enddo
5302 ! 6/20/98 - dihedral angle constraints
5303       edihcnstr=0.0d0
5304       do i=1,ndih_constr
5305         itori=idih_constr(i)
5306         phii=phi(itori)
5307         difi=phii-phi0(i)
5308         if (difi.gt.drange(i)) then
5309           difi=difi-drange(i)
5310           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5311           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5312         else if (difi.lt.-drange(i)) then
5313           difi=difi+drange(i)
5314           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5315           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5316         endif
5317 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5318 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5319       enddo
5320 !      write (iout,*) 'edihcnstr',edihcnstr
5321       return
5322       end
5323 c------------------------------------------------------------------------------
5324 #else
5325       subroutine etor(etors,edihcnstr,fact)
5326       implicit real*8 (a-h,o-z)
5327       include 'DIMENSIONS'
5328       include 'sizesclu.dat'
5329       include 'COMMON.VAR'
5330       include 'COMMON.GEO'
5331       include 'COMMON.LOCAL'
5332       include 'COMMON.TORSION'
5333       include 'COMMON.INTERACT'
5334       include 'COMMON.DERIV'
5335       include 'COMMON.CHAIN'
5336       include 'COMMON.NAMES'
5337       include 'COMMON.IOUNITS'
5338       include 'COMMON.FFIELD'
5339       include 'COMMON.TORCNSTR'
5340       logical lprn
5341 C Set lprn=.true. for debugging
5342       lprn=.false.
5343 c      lprn=.true.
5344       etors=0.0D0
5345       do i=iphi_start,iphi_end
5346         if (i.le.2) cycle
5347         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5348      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5349         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5350          if (iabs(itype(i)).eq.20) then
5351          iblock=2
5352          else
5353          iblock=1
5354          endif
5355         itori=itortyp(itype(i-2))
5356         itori1=itortyp(itype(i-1))
5357         phii=phi(i)
5358         gloci=0.0D0
5359 C Regular cosine and sine terms
5360         do j=1,nterm(itori,itori1,iblock)
5361           v1ij=v1(j,itori,itori1,iblock)
5362           v2ij=v2(j,itori,itori1,iblock)
5363           cosphi=dcos(j*phii)
5364           sinphi=dsin(j*phii)
5365           etors=etors+v1ij*cosphi+v2ij*sinphi
5366           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5367         enddo
5368 C Lorentz terms
5369 C                         v1
5370 C  E = SUM ----------------------------------- - v1
5371 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5372 C
5373         cosphi=dcos(0.5d0*phii)
5374         sinphi=dsin(0.5d0*phii)
5375         do j=1,nlor(itori,itori1,iblock)
5376           vl1ij=vlor1(j,itori,itori1)
5377           vl2ij=vlor2(j,itori,itori1)
5378           vl3ij=vlor3(j,itori,itori1)
5379           pom=vl2ij*cosphi+vl3ij*sinphi
5380           pom1=1.0d0/(pom*pom+1.0d0)
5381           etors=etors+vl1ij*pom1
5382           pom=-pom*pom1*pom1
5383           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5384         enddo
5385 C Subtract the constant term
5386         etors=etors-v0(itori,itori1,iblock)
5387         if (lprn)
5388      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5389      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5390      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5391         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5392 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5393  1215   continue
5394       enddo
5395 ! 6/20/98 - dihedral angle constraints
5396       edihcnstr=0.0d0
5397       do i=1,ndih_constr
5398         itori=idih_constr(i)
5399         phii=phi(itori)
5400         difi=pinorm(phii-phi0(i))
5401         edihi=0.0d0
5402         if (difi.gt.drange(i)) then
5403           difi=difi-drange(i)
5404           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5405           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5406           edihi=0.25d0*ftors(i)*difi**4
5407         else if (difi.lt.-drange(i)) then
5408           difi=difi+drange(i)
5409           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5410           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5411           edihi=0.25d0*ftors(i)*difi**4
5412         else
5413           difi=0.0d0
5414         endif
5415 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5416 c     &    drange(i),edihi
5417 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5418 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5419       enddo
5420 !      write (iout,*) 'edihcnstr',edihcnstr
5421       return
5422       end
5423 c----------------------------------------------------------------------------
5424       subroutine etor_d(etors_d,fact2)
5425 C 6/23/01 Compute double torsional energy
5426       implicit real*8 (a-h,o-z)
5427       include 'DIMENSIONS'
5428       include 'sizesclu.dat'
5429       include 'COMMON.VAR'
5430       include 'COMMON.GEO'
5431       include 'COMMON.LOCAL'
5432       include 'COMMON.TORSION'
5433       include 'COMMON.INTERACT'
5434       include 'COMMON.DERIV'
5435       include 'COMMON.CHAIN'
5436       include 'COMMON.NAMES'
5437       include 'COMMON.IOUNITS'
5438       include 'COMMON.FFIELD'
5439       include 'COMMON.TORCNSTR'
5440       logical lprn
5441 C Set lprn=.true. for debugging
5442       lprn=.false.
5443 c     lprn=.true.
5444       etors_d=0.0D0
5445       do i=iphi_start,iphi_end-1
5446         if (i.le.3) cycle
5447          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5448      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5449      &  (itype(i+1).eq.ntyp1)) cycle
5450         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5451      &     goto 1215
5452         itori=itortyp(itype(i-2))
5453         itori1=itortyp(itype(i-1))
5454         itori2=itortyp(itype(i))
5455         phii=phi(i)
5456         phii1=phi(i+1)
5457         gloci1=0.0D0
5458         gloci2=0.0D0
5459         iblock=1
5460         if (iabs(itype(i+1)).eq.20) iblock=2
5461 C Regular cosine and sine terms
5462        do j=1,ntermd_1(itori,itori1,itori2,iblock)
5463           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5464           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5465           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5466           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5467           cosphi1=dcos(j*phii)
5468           sinphi1=dsin(j*phii)
5469           cosphi2=dcos(j*phii1)
5470           sinphi2=dsin(j*phii1)
5471           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5472      &     v2cij*cosphi2+v2sij*sinphi2
5473           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5474           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5475         enddo
5476         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5477           do l=1,k-1
5478             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5479             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5480             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5481             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5482             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5483             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5484             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5485             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5486             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5487      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5488             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5489      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5490             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5491      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5492           enddo
5493         enddo
5494         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5495         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5496  1215   continue
5497       enddo
5498       return
5499       end
5500 #endif
5501 c------------------------------------------------------------------------------
5502       subroutine eback_sc_corr(esccor)
5503 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5504 c        conformational states; temporarily implemented as differences
5505 c        between UNRES torsional potentials (dependent on three types of
5506 c        residues) and the torsional potentials dependent on all 20 types
5507 c        of residues computed from AM1 energy surfaces of terminally-blocked
5508 c        amino-acid residues.
5509       implicit real*8 (a-h,o-z)
5510       include 'DIMENSIONS'
5511       include 'sizesclu.dat'
5512       include 'COMMON.VAR'
5513       include 'COMMON.GEO'
5514       include 'COMMON.LOCAL'
5515       include 'COMMON.TORSION'
5516       include 'COMMON.SCCOR'
5517       include 'COMMON.INTERACT'
5518       include 'COMMON.DERIV'
5519       include 'COMMON.CHAIN'
5520       include 'COMMON.NAMES'
5521       include 'COMMON.IOUNITS'
5522       include 'COMMON.FFIELD'
5523       include 'COMMON.CONTROL'
5524       logical lprn
5525 C Set lprn=.true. for debugging
5526       lprn=.false.
5527 c      lprn=.true.
5528 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5529       esccor=0.0D0
5530       do i=itau_start,itau_end
5531         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5532         esccor_ii=0.0D0
5533         isccori=isccortyp(itype(i-2))
5534         isccori1=isccortyp(itype(i-1))
5535         phii=phi(i)
5536         do intertyp=1,3 !intertyp
5537 cc Added 09 May 2012 (Adasko)
5538 cc  Intertyp means interaction type of backbone mainchain correlation:
5539 c   1 = SC...Ca...Ca...Ca
5540 c   2 = Ca...Ca...Ca...SC
5541 c   3 = SC...Ca...Ca...SCi
5542         gloci=0.0D0
5543         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5544      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5545      &      (itype(i-1).eq.ntyp1)))
5546      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5547      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5548      &     .or.(itype(i).eq.ntyp1)))
5549      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5550      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5551      &      (itype(i-3).eq.ntyp1)))) cycle
5552         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5553         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5554      & cycle
5555        do j=1,nterm_sccor(isccori,isccori1)
5556           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5557           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5558           cosphi=dcos(j*tauangle(intertyp,i))
5559           sinphi=dsin(j*tauangle(intertyp,i))
5560            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5561 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5562          enddo
5563 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5564 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
5565         if (lprn)
5566      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5567      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5568      &  (v1sccor(j,1,itori,itori1),j=1,6),
5569      &  (v2sccor(j,1,itori,itori1),j=1,6)
5570         gsccor_loc(i-3)=gloci
5571        enddo !intertyp
5572       enddo
5573       return
5574       end
5575 c------------------------------------------------------------------------------
5576       subroutine multibody(ecorr)
5577 C This subroutine calculates multi-body contributions to energy following
5578 C the idea of Skolnick et al. If side chains I and J make a contact and
5579 C at the same time side chains I+1 and J+1 make a contact, an extra
5580 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5581       implicit real*8 (a-h,o-z)
5582       include 'DIMENSIONS'
5583       include 'COMMON.IOUNITS'
5584       include 'COMMON.DERIV'
5585       include 'COMMON.INTERACT'
5586       include 'COMMON.CONTACTS'
5587       double precision gx(3),gx1(3)
5588       logical lprn
5589
5590 C Set lprn=.true. for debugging
5591       lprn=.false.
5592
5593       if (lprn) then
5594         write (iout,'(a)') 'Contact function values:'
5595         do i=nnt,nct-2
5596           write (iout,'(i2,20(1x,i2,f10.5))')
5597      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5598         enddo
5599       endif
5600       ecorr=0.0D0
5601       do i=nnt,nct
5602         do j=1,3
5603           gradcorr(j,i)=0.0D0
5604           gradxorr(j,i)=0.0D0
5605         enddo
5606       enddo
5607       do i=nnt,nct-2
5608
5609         DO ISHIFT = 3,4
5610
5611         i1=i+ishift
5612         num_conti=num_cont(i)
5613         num_conti1=num_cont(i1)
5614         do jj=1,num_conti
5615           j=jcont(jj,i)
5616           do kk=1,num_conti1
5617             j1=jcont(kk,i1)
5618             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5619 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5620 cd   &                   ' ishift=',ishift
5621 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5622 C The system gains extra energy.
5623               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5624             endif   ! j1==j+-ishift
5625           enddo     ! kk
5626         enddo       ! jj
5627
5628         ENDDO ! ISHIFT
5629
5630       enddo         ! i
5631       return
5632       end
5633 c------------------------------------------------------------------------------
5634       double precision function esccorr(i,j,k,l,jj,kk)
5635       implicit real*8 (a-h,o-z)
5636       include 'DIMENSIONS'
5637       include 'COMMON.IOUNITS'
5638       include 'COMMON.DERIV'
5639       include 'COMMON.INTERACT'
5640       include 'COMMON.CONTACTS'
5641       double precision gx(3),gx1(3)
5642       logical lprn
5643       lprn=.false.
5644       eij=facont(jj,i)
5645       ekl=facont(kk,k)
5646 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5647 C Calculate the multi-body contribution to energy.
5648 C Calculate multi-body contributions to the gradient.
5649 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5650 cd   & k,l,(gacont(m,kk,k),m=1,3)
5651       do m=1,3
5652         gx(m) =ekl*gacont(m,jj,i)
5653         gx1(m)=eij*gacont(m,kk,k)
5654         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5655         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5656         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5657         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5658       enddo
5659       do m=i,j-1
5660         do ll=1,3
5661           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5662         enddo
5663       enddo
5664       do m=k,l-1
5665         do ll=1,3
5666           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5667         enddo
5668       enddo
5669       esccorr=-eij*ekl
5670       return
5671       end
5672 c------------------------------------------------------------------------------
5673 #ifdef MPL
5674       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5675       implicit real*8 (a-h,o-z)
5676       include 'DIMENSIONS'
5677       integer dimen1,dimen2,atom,indx
5678       double precision buffer(dimen1,dimen2)
5679       double precision zapas
5680       common /contacts_hb/ zapas(3,20,maxres,7),
5681      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5682      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5683       num_kont=num_cont_hb(atom)
5684       do i=1,num_kont
5685         do k=1,7
5686           do j=1,3
5687             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5688           enddo ! j
5689         enddo ! k
5690         buffer(i,indx+22)=facont_hb(i,atom)
5691         buffer(i,indx+23)=ees0p(i,atom)
5692         buffer(i,indx+24)=ees0m(i,atom)
5693         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5694       enddo ! i
5695       buffer(1,indx+26)=dfloat(num_kont)
5696       return
5697       end
5698 c------------------------------------------------------------------------------
5699       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5700       implicit real*8 (a-h,o-z)
5701       include 'DIMENSIONS'
5702       integer dimen1,dimen2,atom,indx
5703       double precision buffer(dimen1,dimen2)
5704       double precision zapas
5705       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5706      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5707      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5708       num_kont=buffer(1,indx+26)
5709       num_kont_old=num_cont_hb(atom)
5710       num_cont_hb(atom)=num_kont+num_kont_old
5711       do i=1,num_kont
5712         ii=i+num_kont_old
5713         do k=1,7
5714           do j=1,3
5715             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5716           enddo ! j
5717         enddo ! k
5718         facont_hb(ii,atom)=buffer(i,indx+22)
5719         ees0p(ii,atom)=buffer(i,indx+23)
5720         ees0m(ii,atom)=buffer(i,indx+24)
5721         jcont_hb(ii,atom)=buffer(i,indx+25)
5722       enddo ! i
5723       return
5724       end
5725 c------------------------------------------------------------------------------
5726 #endif
5727       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5728 C This subroutine calculates multi-body contributions to hydrogen-bonding
5729       implicit real*8 (a-h,o-z)
5730       include 'DIMENSIONS'
5731       include 'sizesclu.dat'
5732       include 'COMMON.IOUNITS'
5733 #ifdef MPL
5734       include 'COMMON.INFO'
5735 #endif
5736       include 'COMMON.FFIELD'
5737       include 'COMMON.DERIV'
5738       include 'COMMON.INTERACT'
5739       include 'COMMON.CONTACTS'
5740 #ifdef MPL
5741       parameter (max_cont=maxconts)
5742       parameter (max_dim=2*(8*3+2))
5743       parameter (msglen1=max_cont*max_dim*4)
5744       parameter (msglen2=2*msglen1)
5745       integer source,CorrelType,CorrelID,Error
5746       double precision buffer(max_cont,max_dim)
5747 #endif
5748       double precision gx(3),gx1(3)
5749       logical lprn,ldone
5750
5751 C Set lprn=.true. for debugging
5752       lprn=.false.
5753 #ifdef MPL
5754       n_corr=0
5755       n_corr1=0
5756       if (fgProcs.le.1) goto 30
5757       if (lprn) then
5758         write (iout,'(a)') 'Contact function values:'
5759         do i=nnt,nct-2
5760           write (iout,'(2i3,50(1x,i2,f5.2))')
5761      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5762      &    j=1,num_cont_hb(i))
5763         enddo
5764       endif
5765 C Caution! Following code assumes that electrostatic interactions concerning
5766 C a given atom are split among at most two processors!
5767       CorrelType=477
5768       CorrelID=MyID+1
5769       ldone=.false.
5770       do i=1,max_cont
5771         do j=1,max_dim
5772           buffer(i,j)=0.0D0
5773         enddo
5774       enddo
5775       mm=mod(MyRank,2)
5776 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5777       if (mm) 20,20,10
5778    10 continue
5779 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5780       if (MyRank.gt.0) then
5781 C Send correlation contributions to the preceding processor
5782         msglen=msglen1
5783         nn=num_cont_hb(iatel_s)
5784         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5785 cd      write (iout,*) 'The BUFFER array:'
5786 cd      do i=1,nn
5787 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5788 cd      enddo
5789         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5790           msglen=msglen2
5791             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5792 C Clear the contacts of the atom passed to the neighboring processor
5793         nn=num_cont_hb(iatel_s+1)
5794 cd      do i=1,nn
5795 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5796 cd      enddo
5797             num_cont_hb(iatel_s)=0
5798         endif
5799 cd      write (iout,*) 'Processor ',MyID,MyRank,
5800 cd   & ' is sending correlation contribution to processor',MyID-1,
5801 cd   & ' msglen=',msglen
5802 cd      write (*,*) 'Processor ',MyID,MyRank,
5803 cd   & ' is sending correlation contribution to processor',MyID-1,
5804 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5805         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5806 cd      write (iout,*) 'Processor ',MyID,
5807 cd   & ' has sent correlation contribution to processor',MyID-1,
5808 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5809 cd      write (*,*) 'Processor ',MyID,
5810 cd   & ' has sent correlation contribution to processor',MyID-1,
5811 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5812         msglen=msglen1
5813       endif ! (MyRank.gt.0)
5814       if (ldone) goto 30
5815       ldone=.true.
5816    20 continue
5817 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5818       if (MyRank.lt.fgProcs-1) then
5819 C Receive correlation contributions from the next processor
5820         msglen=msglen1
5821         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5822 cd      write (iout,*) 'Processor',MyID,
5823 cd   & ' is receiving correlation contribution from processor',MyID+1,
5824 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5825 cd      write (*,*) 'Processor',MyID,
5826 cd   & ' is receiving correlation contribution from processor',MyID+1,
5827 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5828         nbytes=-1
5829         do while (nbytes.le.0)
5830           call mp_probe(MyID+1,CorrelType,nbytes)
5831         enddo
5832 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5833         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5834 cd      write (iout,*) 'Processor',MyID,
5835 cd   & ' has received correlation contribution from processor',MyID+1,
5836 cd   & ' msglen=',msglen,' nbytes=',nbytes
5837 cd      write (iout,*) 'The received BUFFER array:'
5838 cd      do i=1,max_cont
5839 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5840 cd      enddo
5841         if (msglen.eq.msglen1) then
5842           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5843         else if (msglen.eq.msglen2)  then
5844           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5845           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5846         else
5847           write (iout,*)
5848      & 'ERROR!!!! message length changed while processing correlations.'
5849           write (*,*)
5850      & 'ERROR!!!! message length changed while processing correlations.'
5851           call mp_stopall(Error)
5852         endif ! msglen.eq.msglen1
5853       endif ! MyRank.lt.fgProcs-1
5854       if (ldone) goto 30
5855       ldone=.true.
5856       goto 10
5857    30 continue
5858 #endif
5859       if (lprn) then
5860         write (iout,'(a)') 'Contact function values:'
5861         do i=nnt,nct-2
5862           write (iout,'(2i3,50(1x,i2,f5.2))')
5863      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5864      &    j=1,num_cont_hb(i))
5865         enddo
5866       endif
5867       ecorr=0.0D0
5868 C Remove the loop below after debugging !!!
5869       do i=nnt,nct
5870         do j=1,3
5871           gradcorr(j,i)=0.0D0
5872           gradxorr(j,i)=0.0D0
5873         enddo
5874       enddo
5875 C Calculate the local-electrostatic correlation terms
5876       do i=iatel_s,iatel_e+1
5877         i1=i+1
5878         num_conti=num_cont_hb(i)
5879         num_conti1=num_cont_hb(i+1)
5880         do jj=1,num_conti
5881           j=jcont_hb(jj,i)
5882           do kk=1,num_conti1
5883             j1=jcont_hb(kk,i1)
5884 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5885 c     &         ' jj=',jj,' kk=',kk
5886             if (j1.eq.j+1 .or. j1.eq.j-1) then
5887 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5888 C The system gains extra energy.
5889               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5890               n_corr=n_corr+1
5891             else if (j1.eq.j) then
5892 C Contacts I-J and I-(J+1) occur simultaneously.
5893 C The system loses extra energy.
5894 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5895             endif
5896           enddo ! kk
5897           do kk=1,num_conti
5898             j1=jcont_hb(kk,i)
5899 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5900 c    &         ' jj=',jj,' kk=',kk
5901             if (j1.eq.j+1) then
5902 C Contacts I-J and (I+1)-J occur simultaneously.
5903 C The system loses extra energy.
5904 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5905             endif ! j1==j+1
5906           enddo ! kk
5907         enddo ! jj
5908       enddo ! i
5909       return
5910       end
5911 c------------------------------------------------------------------------------
5912       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5913      &  n_corr1)
5914 C This subroutine calculates multi-body contributions to hydrogen-bonding
5915       implicit real*8 (a-h,o-z)
5916       include 'DIMENSIONS'
5917       include 'sizesclu.dat'
5918       include 'COMMON.IOUNITS'
5919 #ifdef MPL
5920       include 'COMMON.INFO'
5921 #endif
5922       include 'COMMON.FFIELD'
5923       include 'COMMON.DERIV'
5924       include 'COMMON.INTERACT'
5925       include 'COMMON.CONTACTS'
5926 #ifdef MPL
5927       parameter (max_cont=maxconts)
5928       parameter (max_dim=2*(8*3+2))
5929       parameter (msglen1=max_cont*max_dim*4)
5930       parameter (msglen2=2*msglen1)
5931       integer source,CorrelType,CorrelID,Error
5932       double precision buffer(max_cont,max_dim)
5933 #endif
5934       double precision gx(3),gx1(3)
5935       logical lprn,ldone
5936
5937 C Set lprn=.true. for debugging
5938       lprn=.false.
5939       eturn6=0.0d0
5940 #ifdef MPL
5941       n_corr=0
5942       n_corr1=0
5943       if (fgProcs.le.1) goto 30
5944       if (lprn) then
5945         write (iout,'(a)') 'Contact function values:'
5946         do i=nnt,nct-2
5947           write (iout,'(2i3,50(1x,i2,f5.2))')
5948      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5949      &    j=1,num_cont_hb(i))
5950         enddo
5951       endif
5952 C Caution! Following code assumes that electrostatic interactions concerning
5953 C a given atom are split among at most two processors!
5954       CorrelType=477
5955       CorrelID=MyID+1
5956       ldone=.false.
5957       do i=1,max_cont
5958         do j=1,max_dim
5959           buffer(i,j)=0.0D0
5960         enddo
5961       enddo
5962       mm=mod(MyRank,2)
5963 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5964       if (mm) 20,20,10
5965    10 continue
5966 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5967       if (MyRank.gt.0) then
5968 C Send correlation contributions to the preceding processor
5969         msglen=msglen1
5970         nn=num_cont_hb(iatel_s)
5971         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5972 cd      write (iout,*) 'The BUFFER array:'
5973 cd      do i=1,nn
5974 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5975 cd      enddo
5976         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5977           msglen=msglen2
5978             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5979 C Clear the contacts of the atom passed to the neighboring processor
5980         nn=num_cont_hb(iatel_s+1)
5981 cd      do i=1,nn
5982 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5983 cd      enddo
5984             num_cont_hb(iatel_s)=0
5985         endif
5986 cd      write (iout,*) 'Processor ',MyID,MyRank,
5987 cd   & ' is sending correlation contribution to processor',MyID-1,
5988 cd   & ' msglen=',msglen
5989 cd      write (*,*) 'Processor ',MyID,MyRank,
5990 cd   & ' is sending correlation contribution to processor',MyID-1,
5991 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5992         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5993 cd      write (iout,*) 'Processor ',MyID,
5994 cd   & ' has sent correlation contribution to processor',MyID-1,
5995 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5996 cd      write (*,*) 'Processor ',MyID,
5997 cd   & ' has sent correlation contribution to processor',MyID-1,
5998 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5999         msglen=msglen1
6000       endif ! (MyRank.gt.0)
6001       if (ldone) goto 30
6002       ldone=.true.
6003    20 continue
6004 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6005       if (MyRank.lt.fgProcs-1) then
6006 C Receive correlation contributions from the next processor
6007         msglen=msglen1
6008         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6009 cd      write (iout,*) 'Processor',MyID,
6010 cd   & ' is receiving correlation contribution from processor',MyID+1,
6011 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6012 cd      write (*,*) 'Processor',MyID,
6013 cd   & ' is receiving correlation contribution from processor',MyID+1,
6014 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6015         nbytes=-1
6016         do while (nbytes.le.0)
6017           call mp_probe(MyID+1,CorrelType,nbytes)
6018         enddo
6019 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6020         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6021 cd      write (iout,*) 'Processor',MyID,
6022 cd   & ' has received correlation contribution from processor',MyID+1,
6023 cd   & ' msglen=',msglen,' nbytes=',nbytes
6024 cd      write (iout,*) 'The received BUFFER array:'
6025 cd      do i=1,max_cont
6026 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6027 cd      enddo
6028         if (msglen.eq.msglen1) then
6029           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6030         else if (msglen.eq.msglen2)  then
6031           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6032           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6033         else
6034           write (iout,*)
6035      & 'ERROR!!!! message length changed while processing correlations.'
6036           write (*,*)
6037      & 'ERROR!!!! message length changed while processing correlations.'
6038           call mp_stopall(Error)
6039         endif ! msglen.eq.msglen1
6040       endif ! MyRank.lt.fgProcs-1
6041       if (ldone) goto 30
6042       ldone=.true.
6043       goto 10
6044    30 continue
6045 #endif
6046       if (lprn) then
6047         write (iout,'(a)') 'Contact function values:'
6048         do i=nnt,nct-2
6049           write (iout,'(2i3,50(1x,i2,f5.2))')
6050      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6051      &    j=1,num_cont_hb(i))
6052         enddo
6053       endif
6054       ecorr=0.0D0
6055       ecorr5=0.0d0
6056       ecorr6=0.0d0
6057 C Remove the loop below after debugging !!!
6058       do i=nnt,nct
6059         do j=1,3
6060           gradcorr(j,i)=0.0D0
6061           gradxorr(j,i)=0.0D0
6062         enddo
6063       enddo
6064 C Calculate the dipole-dipole interaction energies
6065       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6066       do i=iatel_s,iatel_e+1
6067         num_conti=num_cont_hb(i)
6068         do jj=1,num_conti
6069           j=jcont_hb(jj,i)
6070           call dipole(i,j,jj)
6071         enddo
6072       enddo
6073       endif
6074 C Calculate the local-electrostatic correlation terms
6075       do i=iatel_s,iatel_e+1
6076         i1=i+1
6077         num_conti=num_cont_hb(i)
6078         num_conti1=num_cont_hb(i+1)
6079         do jj=1,num_conti
6080           j=jcont_hb(jj,i)
6081           do kk=1,num_conti1
6082             j1=jcont_hb(kk,i1)
6083 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6084 c     &         ' jj=',jj,' kk=',kk
6085             if (j1.eq.j+1 .or. j1.eq.j-1) then
6086 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6087 C The system gains extra energy.
6088               n_corr=n_corr+1
6089               sqd1=dsqrt(d_cont(jj,i))
6090               sqd2=dsqrt(d_cont(kk,i1))
6091               sred_geom = sqd1*sqd2
6092               IF (sred_geom.lt.cutoff_corr) THEN
6093                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6094      &            ekont,fprimcont)
6095 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6096 c     &         ' jj=',jj,' kk=',kk
6097                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6098                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6099                 do l=1,3
6100                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6101                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6102                 enddo
6103                 n_corr1=n_corr1+1
6104 cd               write (iout,*) 'sred_geom=',sred_geom,
6105 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6106                 call calc_eello(i,j,i+1,j1,jj,kk)
6107                 if (wcorr4.gt.0.0d0)
6108      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6109                 if (wcorr5.gt.0.0d0)
6110      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6111 c                print *,"wcorr5",ecorr5
6112 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6113 cd                write(2,*)'ijkl',i,j,i+1,j1
6114                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6115      &               .or. wturn6.eq.0.0d0))then
6116 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6117                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6118 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6119 cd     &            'ecorr6=',ecorr6
6120 cd                write (iout,'(4e15.5)') sred_geom,
6121 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6122 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6123 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6124                 else if (wturn6.gt.0.0d0
6125      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6126 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6127                   eturn6=eturn6+eello_turn6(i,jj,kk)
6128 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6129                 endif
6130               ENDIF
6131 1111          continue
6132             else if (j1.eq.j) then
6133 C Contacts I-J and I-(J+1) occur simultaneously.
6134 C The system loses extra energy.
6135 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6136             endif
6137           enddo ! kk
6138           do kk=1,num_conti
6139             j1=jcont_hb(kk,i)
6140 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6141 c    &         ' jj=',jj,' kk=',kk
6142             if (j1.eq.j+1) then
6143 C Contacts I-J and (I+1)-J occur simultaneously.
6144 C The system loses extra energy.
6145 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6146             endif ! j1==j+1
6147           enddo ! kk
6148         enddo ! jj
6149       enddo ! i
6150       return
6151       end
6152 c------------------------------------------------------------------------------
6153       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6154       implicit real*8 (a-h,o-z)
6155       include 'DIMENSIONS'
6156       include 'COMMON.IOUNITS'
6157       include 'COMMON.DERIV'
6158       include 'COMMON.INTERACT'
6159       include 'COMMON.CONTACTS'
6160       include 'COMMON.SHIELD'
6161
6162       double precision gx(3),gx1(3)
6163       logical lprn
6164       lprn=.false.
6165       eij=facont_hb(jj,i)
6166       ekl=facont_hb(kk,k)
6167       ees0pij=ees0p(jj,i)
6168       ees0pkl=ees0p(kk,k)
6169       ees0mij=ees0m(jj,i)
6170       ees0mkl=ees0m(kk,k)
6171       ekont=eij*ekl
6172       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6173 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6174 C Following 4 lines for diagnostics.
6175 cd    ees0pkl=0.0D0
6176 cd    ees0pij=1.0D0
6177 cd    ees0mkl=0.0D0
6178 cd    ees0mij=1.0D0
6179 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6180 c    &   ' and',k,l
6181 c     write (iout,*)'Contacts have occurred for peptide groups',
6182 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6183 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6184 C Calculate the multi-body contribution to energy.
6185       ecorr=ecorr+ekont*ees
6186       if (calc_grad) then
6187 C Calculate multi-body contributions to the gradient.
6188       do ll=1,3
6189         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6190         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6191      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6192      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6193         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6194      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6195      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6196         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6197         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6198      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6199      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6200         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6201      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6202      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6203       enddo
6204       do m=i+1,j-1
6205         do ll=1,3
6206           gradcorr(ll,m)=gradcorr(ll,m)+
6207      &     ees*ekl*gacont_hbr(ll,jj,i)-
6208      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6209      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6210         enddo
6211       enddo
6212       do m=k+1,l-1
6213         do ll=1,3
6214           gradcorr(ll,m)=gradcorr(ll,m)+
6215      &     ees*eij*gacont_hbr(ll,kk,k)-
6216      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6217      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6218         enddo
6219       enddo
6220       if (shield_mode.gt.0) then
6221        j=ees0plist(jj,i)
6222        l=ees0plist(kk,k)
6223 C        print *,i,j,fac_shield(i),fac_shield(j),
6224 C     &fac_shield(k),fac_shield(l)
6225         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6226      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6227           do ilist=1,ishield_list(i)
6228            iresshield=shield_list(ilist,i)
6229            do m=1,3
6230            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6231 C     &      *2.0
6232            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6233      &              rlocshield
6234      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6235             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6236      &+rlocshield
6237            enddo
6238           enddo
6239           do ilist=1,ishield_list(j)
6240            iresshield=shield_list(ilist,j)
6241            do m=1,3
6242            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6243 C     &     *2.0
6244            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6245      &              rlocshield
6246      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6247            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6248      &     +rlocshield
6249            enddo
6250           enddo
6251           do ilist=1,ishield_list(k)
6252            iresshield=shield_list(ilist,k)
6253            do m=1,3
6254            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6255 C     &     *2.0
6256            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6257      &              rlocshield
6258      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6259            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6260      &     +rlocshield
6261            enddo
6262           enddo
6263           do ilist=1,ishield_list(l)
6264            iresshield=shield_list(ilist,l)
6265            do m=1,3
6266            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6267 C     &     *2.0
6268            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6269      &              rlocshield
6270      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6271            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6272      &     +rlocshield
6273            enddo
6274           enddo
6275 C          print *,gshieldx(m,iresshield)
6276           do m=1,3
6277             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6278      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6279             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6280      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6281             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6282      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6283             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6284      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6285
6286             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6287      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6288             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6289      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6290             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6291      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6292             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6293      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6294
6295            enddo
6296       endif
6297       endif
6298       endif
6299       ehbcorr=ekont*ees
6300       return
6301       end
6302 C---------------------------------------------------------------------------
6303       subroutine dipole(i,j,jj)
6304       implicit real*8 (a-h,o-z)
6305       include 'DIMENSIONS'
6306       include 'sizesclu.dat'
6307       include 'COMMON.IOUNITS'
6308       include 'COMMON.CHAIN'
6309       include 'COMMON.FFIELD'
6310       include 'COMMON.DERIV'
6311       include 'COMMON.INTERACT'
6312       include 'COMMON.CONTACTS'
6313       include 'COMMON.TORSION'
6314       include 'COMMON.VAR'
6315       include 'COMMON.GEO'
6316       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6317      &  auxmat(2,2)
6318       iti1 = itortyp(itype(i+1))
6319       if (j.lt.nres-1) then
6320         if (itype(j).le.ntyp) then
6321           itj1 = itortyp(itype(j+1))
6322         else
6323           itj1=ntortyp+1
6324         endif
6325       else
6326         itj1=ntortyp+1
6327       endif
6328       do iii=1,2
6329         dipi(iii,1)=Ub2(iii,i)
6330         dipderi(iii)=Ub2der(iii,i)
6331         dipi(iii,2)=b1(iii,iti1)
6332         dipj(iii,1)=Ub2(iii,j)
6333         dipderj(iii)=Ub2der(iii,j)
6334         dipj(iii,2)=b1(iii,itj1)
6335       enddo
6336       kkk=0
6337       do iii=1,2
6338         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6339         do jjj=1,2
6340           kkk=kkk+1
6341           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6342         enddo
6343       enddo
6344       if (.not.calc_grad) return
6345       do kkk=1,5
6346         do lll=1,3
6347           mmm=0
6348           do iii=1,2
6349             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6350      &        auxvec(1))
6351             do jjj=1,2
6352               mmm=mmm+1
6353               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6354             enddo
6355           enddo
6356         enddo
6357       enddo
6358       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6359       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6360       do iii=1,2
6361         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6362       enddo
6363       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6364       do iii=1,2
6365         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6366       enddo
6367       return
6368       end
6369 C---------------------------------------------------------------------------
6370       subroutine calc_eello(i,j,k,l,jj,kk)
6371 C
6372 C This subroutine computes matrices and vectors needed to calculate
6373 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6374 C
6375       implicit real*8 (a-h,o-z)
6376       include 'DIMENSIONS'
6377       include 'sizesclu.dat'
6378       include 'COMMON.IOUNITS'
6379       include 'COMMON.CHAIN'
6380       include 'COMMON.DERIV'
6381       include 'COMMON.INTERACT'
6382       include 'COMMON.CONTACTS'
6383       include 'COMMON.TORSION'
6384       include 'COMMON.VAR'
6385       include 'COMMON.GEO'
6386       include 'COMMON.FFIELD'
6387       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6388      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6389       logical lprn
6390       common /kutas/ lprn
6391 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6392 cd     & ' jj=',jj,' kk=',kk
6393 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6394       do iii=1,2
6395         do jjj=1,2
6396           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6397           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6398         enddo
6399       enddo
6400       call transpose2(aa1(1,1),aa1t(1,1))
6401       call transpose2(aa2(1,1),aa2t(1,1))
6402       do kkk=1,5
6403         do lll=1,3
6404           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6405      &      aa1tder(1,1,lll,kkk))
6406           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6407      &      aa2tder(1,1,lll,kkk))
6408         enddo
6409       enddo
6410       if (l.eq.j+1) then
6411 C parallel orientation of the two CA-CA-CA frames.
6412 c        if (i.gt.1) then
6413         if (i.gt.1 .and. itype(i).le.ntyp) then
6414           iti=itortyp(itype(i))
6415         else
6416           iti=ntortyp+1
6417         endif
6418         itk1=itortyp(itype(k+1))
6419         itj=itortyp(itype(j))
6420 c        if (l.lt.nres-1) then
6421         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6422           itl1=itortyp(itype(l+1))
6423         else
6424           itl1=ntortyp+1
6425         endif
6426 C A1 kernel(j+1) A2T
6427 cd        do iii=1,2
6428 cd          write (iout,'(3f10.5,5x,3f10.5)')
6429 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6430 cd        enddo
6431         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6432      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6433      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6434 C Following matrices are needed only for 6-th order cumulants
6435         IF (wcorr6.gt.0.0d0) THEN
6436         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6437      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6438      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6439         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6440      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6441      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6442      &   ADtEAderx(1,1,1,1,1,1))
6443         lprn=.false.
6444         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6445      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6446      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6447      &   ADtEA1derx(1,1,1,1,1,1))
6448         ENDIF
6449 C End 6-th order cumulants
6450 cd        lprn=.false.
6451 cd        if (lprn) then
6452 cd        write (2,*) 'In calc_eello6'
6453 cd        do iii=1,2
6454 cd          write (2,*) 'iii=',iii
6455 cd          do kkk=1,5
6456 cd            write (2,*) 'kkk=',kkk
6457 cd            do jjj=1,2
6458 cd              write (2,'(3(2f10.5),5x)')
6459 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6460 cd            enddo
6461 cd          enddo
6462 cd        enddo
6463 cd        endif
6464         call transpose2(EUgder(1,1,k),auxmat(1,1))
6465         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6466         call transpose2(EUg(1,1,k),auxmat(1,1))
6467         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6468         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6469         do iii=1,2
6470           do kkk=1,5
6471             do lll=1,3
6472               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6473      &          EAEAderx(1,1,lll,kkk,iii,1))
6474             enddo
6475           enddo
6476         enddo
6477 C A1T kernel(i+1) A2
6478         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6479      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6480      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6481 C Following matrices are needed only for 6-th order cumulants
6482         IF (wcorr6.gt.0.0d0) THEN
6483         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6484      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6485      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6486         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6487      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6488      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6489      &   ADtEAderx(1,1,1,1,1,2))
6490         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6491      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6492      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6493      &   ADtEA1derx(1,1,1,1,1,2))
6494         ENDIF
6495 C End 6-th order cumulants
6496         call transpose2(EUgder(1,1,l),auxmat(1,1))
6497         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6498         call transpose2(EUg(1,1,l),auxmat(1,1))
6499         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6500         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6501         do iii=1,2
6502           do kkk=1,5
6503             do lll=1,3
6504               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6505      &          EAEAderx(1,1,lll,kkk,iii,2))
6506             enddo
6507           enddo
6508         enddo
6509 C AEAb1 and AEAb2
6510 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6511 C They are needed only when the fifth- or the sixth-order cumulants are
6512 C indluded.
6513         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6514         call transpose2(AEA(1,1,1),auxmat(1,1))
6515         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6516         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6517         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6518         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6519         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6520         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6521         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6522         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6523         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6524         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6525         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6526         call transpose2(AEA(1,1,2),auxmat(1,1))
6527         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6528         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6529         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6530         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6531         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6532         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6533         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6534         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6535         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6536         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6537         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6538 C Calculate the Cartesian derivatives of the vectors.
6539         do iii=1,2
6540           do kkk=1,5
6541             do lll=1,3
6542               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6543               call matvec2(auxmat(1,1),b1(1,iti),
6544      &          AEAb1derx(1,lll,kkk,iii,1,1))
6545               call matvec2(auxmat(1,1),Ub2(1,i),
6546      &          AEAb2derx(1,lll,kkk,iii,1,1))
6547               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6548      &          AEAb1derx(1,lll,kkk,iii,2,1))
6549               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6550      &          AEAb2derx(1,lll,kkk,iii,2,1))
6551               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6552               call matvec2(auxmat(1,1),b1(1,itj),
6553      &          AEAb1derx(1,lll,kkk,iii,1,2))
6554               call matvec2(auxmat(1,1),Ub2(1,j),
6555      &          AEAb2derx(1,lll,kkk,iii,1,2))
6556               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6557      &          AEAb1derx(1,lll,kkk,iii,2,2))
6558               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6559      &          AEAb2derx(1,lll,kkk,iii,2,2))
6560             enddo
6561           enddo
6562         enddo
6563         ENDIF
6564 C End vectors
6565       else
6566 C Antiparallel orientation of the two CA-CA-CA frames.
6567 c        if (i.gt.1) then
6568         if (i.gt.1 .and. itype(i).le.ntyp) then
6569           iti=itortyp(itype(i))
6570         else
6571           iti=ntortyp+1
6572         endif
6573         itk1=itortyp(itype(k+1))
6574         itl=itortyp(itype(l))
6575         itj=itortyp(itype(j))
6576 c        if (j.lt.nres-1) then
6577         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6578           itj1=itortyp(itype(j+1))
6579         else
6580           itj1=ntortyp+1
6581         endif
6582 C A2 kernel(j-1)T A1T
6583         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6584      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6585      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6586 C Following matrices are needed only for 6-th order cumulants
6587         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6588      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6589         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6590      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6591      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6592         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6593      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6594      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6595      &   ADtEAderx(1,1,1,1,1,1))
6596         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6597      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6598      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6599      &   ADtEA1derx(1,1,1,1,1,1))
6600         ENDIF
6601 C End 6-th order cumulants
6602         call transpose2(EUgder(1,1,k),auxmat(1,1))
6603         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6604         call transpose2(EUg(1,1,k),auxmat(1,1))
6605         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6606         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6607         do iii=1,2
6608           do kkk=1,5
6609             do lll=1,3
6610               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6611      &          EAEAderx(1,1,lll,kkk,iii,1))
6612             enddo
6613           enddo
6614         enddo
6615 C A2T kernel(i+1)T A1
6616         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6617      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6618      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6619 C Following matrices are needed only for 6-th order cumulants
6620         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6621      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6622         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6623      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6624      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6625         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6626      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6627      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6628      &   ADtEAderx(1,1,1,1,1,2))
6629         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6630      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6631      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6632      &   ADtEA1derx(1,1,1,1,1,2))
6633         ENDIF
6634 C End 6-th order cumulants
6635         call transpose2(EUgder(1,1,j),auxmat(1,1))
6636         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6637         call transpose2(EUg(1,1,j),auxmat(1,1))
6638         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6639         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6640         do iii=1,2
6641           do kkk=1,5
6642             do lll=1,3
6643               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6644      &          EAEAderx(1,1,lll,kkk,iii,2))
6645             enddo
6646           enddo
6647         enddo
6648 C AEAb1 and AEAb2
6649 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6650 C They are needed only when the fifth- or the sixth-order cumulants are
6651 C indluded.
6652         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6653      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6654         call transpose2(AEA(1,1,1),auxmat(1,1))
6655         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6656         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6657         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6658         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6659         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6660         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6661         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6662         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6663         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6664         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6665         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6666         call transpose2(AEA(1,1,2),auxmat(1,1))
6667         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6668         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6669         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6670         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6671         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6672         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6673         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6674         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6675         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6676         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6677         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6678 C Calculate the Cartesian derivatives of the vectors.
6679         do iii=1,2
6680           do kkk=1,5
6681             do lll=1,3
6682               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6683               call matvec2(auxmat(1,1),b1(1,iti),
6684      &          AEAb1derx(1,lll,kkk,iii,1,1))
6685               call matvec2(auxmat(1,1),Ub2(1,i),
6686      &          AEAb2derx(1,lll,kkk,iii,1,1))
6687               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6688      &          AEAb1derx(1,lll,kkk,iii,2,1))
6689               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6690      &          AEAb2derx(1,lll,kkk,iii,2,1))
6691               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6692               call matvec2(auxmat(1,1),b1(1,itl),
6693      &          AEAb1derx(1,lll,kkk,iii,1,2))
6694               call matvec2(auxmat(1,1),Ub2(1,l),
6695      &          AEAb2derx(1,lll,kkk,iii,1,2))
6696               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6697      &          AEAb1derx(1,lll,kkk,iii,2,2))
6698               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6699      &          AEAb2derx(1,lll,kkk,iii,2,2))
6700             enddo
6701           enddo
6702         enddo
6703         ENDIF
6704 C End vectors
6705       endif
6706       return
6707       end
6708 C---------------------------------------------------------------------------
6709       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6710      &  KK,KKderg,AKA,AKAderg,AKAderx)
6711       implicit none
6712       integer nderg
6713       logical transp
6714       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6715      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6716      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6717       integer iii,kkk,lll
6718       integer jjj,mmm
6719       logical lprn
6720       common /kutas/ lprn
6721       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6722       do iii=1,nderg
6723         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6724      &    AKAderg(1,1,iii))
6725       enddo
6726 cd      if (lprn) write (2,*) 'In kernel'
6727       do kkk=1,5
6728 cd        if (lprn) write (2,*) 'kkk=',kkk
6729         do lll=1,3
6730           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6731      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6732 cd          if (lprn) then
6733 cd            write (2,*) 'lll=',lll
6734 cd            write (2,*) 'iii=1'
6735 cd            do jjj=1,2
6736 cd              write (2,'(3(2f10.5),5x)')
6737 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6738 cd            enddo
6739 cd          endif
6740           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6741      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6742 cd          if (lprn) then
6743 cd            write (2,*) 'lll=',lll
6744 cd            write (2,*) 'iii=2'
6745 cd            do jjj=1,2
6746 cd              write (2,'(3(2f10.5),5x)')
6747 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6748 cd            enddo
6749 cd          endif
6750         enddo
6751       enddo
6752       return
6753       end
6754 C---------------------------------------------------------------------------
6755       double precision function eello4(i,j,k,l,jj,kk)
6756       implicit real*8 (a-h,o-z)
6757       include 'DIMENSIONS'
6758       include 'sizesclu.dat'
6759       include 'COMMON.IOUNITS'
6760       include 'COMMON.CHAIN'
6761       include 'COMMON.DERIV'
6762       include 'COMMON.INTERACT'
6763       include 'COMMON.CONTACTS'
6764       include 'COMMON.TORSION'
6765       include 'COMMON.VAR'
6766       include 'COMMON.GEO'
6767       double precision pizda(2,2),ggg1(3),ggg2(3)
6768 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6769 cd        eello4=0.0d0
6770 cd        return
6771 cd      endif
6772 cd      print *,'eello4:',i,j,k,l,jj,kk
6773 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6774 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6775 cold      eij=facont_hb(jj,i)
6776 cold      ekl=facont_hb(kk,k)
6777 cold      ekont=eij*ekl
6778       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6779       if (calc_grad) then
6780 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6781       gcorr_loc(k-1)=gcorr_loc(k-1)
6782      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6783       if (l.eq.j+1) then
6784         gcorr_loc(l-1)=gcorr_loc(l-1)
6785      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6786       else
6787         gcorr_loc(j-1)=gcorr_loc(j-1)
6788      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6789       endif
6790       do iii=1,2
6791         do kkk=1,5
6792           do lll=1,3
6793             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6794      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6795 cd            derx(lll,kkk,iii)=0.0d0
6796           enddo
6797         enddo
6798       enddo
6799 cd      gcorr_loc(l-1)=0.0d0
6800 cd      gcorr_loc(j-1)=0.0d0
6801 cd      gcorr_loc(k-1)=0.0d0
6802 cd      eel4=1.0d0
6803 cd      write (iout,*)'Contacts have occurred for peptide groups',
6804 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6805 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6806       if (j.lt.nres-1) then
6807         j1=j+1
6808         j2=j-1
6809       else
6810         j1=j-1
6811         j2=j-2
6812       endif
6813       if (l.lt.nres-1) then
6814         l1=l+1
6815         l2=l-1
6816       else
6817         l1=l-1
6818         l2=l-2
6819       endif
6820       do ll=1,3
6821 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6822         ggg1(ll)=eel4*g_contij(ll,1)
6823         ggg2(ll)=eel4*g_contij(ll,2)
6824         ghalf=0.5d0*ggg1(ll)
6825 cd        ghalf=0.0d0
6826         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6827         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6828         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6829         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6830 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6831         ghalf=0.5d0*ggg2(ll)
6832 cd        ghalf=0.0d0
6833         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6834         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6835         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6836         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6837       enddo
6838 cd      goto 1112
6839       do m=i+1,j-1
6840         do ll=1,3
6841 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6842           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6843         enddo
6844       enddo
6845       do m=k+1,l-1
6846         do ll=1,3
6847 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6848           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6849         enddo
6850       enddo
6851 1112  continue
6852       do m=i+2,j2
6853         do ll=1,3
6854           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6855         enddo
6856       enddo
6857       do m=k+2,l2
6858         do ll=1,3
6859           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6860         enddo
6861       enddo
6862 cd      do iii=1,nres-3
6863 cd        write (2,*) iii,gcorr_loc(iii)
6864 cd      enddo
6865       endif
6866       eello4=ekont*eel4
6867 cd      write (2,*) 'ekont',ekont
6868 cd      write (iout,*) 'eello4',ekont*eel4
6869       return
6870       end
6871 C---------------------------------------------------------------------------
6872       double precision function eello5(i,j,k,l,jj,kk)
6873       implicit real*8 (a-h,o-z)
6874       include 'DIMENSIONS'
6875       include 'sizesclu.dat'
6876       include 'COMMON.IOUNITS'
6877       include 'COMMON.CHAIN'
6878       include 'COMMON.DERIV'
6879       include 'COMMON.INTERACT'
6880       include 'COMMON.CONTACTS'
6881       include 'COMMON.TORSION'
6882       include 'COMMON.VAR'
6883       include 'COMMON.GEO'
6884       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6885       double precision ggg1(3),ggg2(3)
6886 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6887 C                                                                              C
6888 C                            Parallel chains                                   C
6889 C                                                                              C
6890 C          o             o                   o             o                   C
6891 C         /l\           / \             \   / \           / \   /              C
6892 C        /   \         /   \             \ /   \         /   \ /               C
6893 C       j| o |l1       | o |              o| o |         | o |o                C
6894 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6895 C      \i/   \         /   \ /             /   \         /   \                 C
6896 C       o    k1             o                                                  C
6897 C         (I)          (II)                (III)          (IV)                 C
6898 C                                                                              C
6899 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6900 C                                                                              C
6901 C                            Antiparallel chains                               C
6902 C                                                                              C
6903 C          o             o                   o             o                   C
6904 C         /j\           / \             \   / \           / \   /              C
6905 C        /   \         /   \             \ /   \         /   \ /               C
6906 C      j1| o |l        | o |              o| o |         | o |o                C
6907 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6908 C      \i/   \         /   \ /             /   \         /   \                 C
6909 C       o     k1            o                                                  C
6910 C         (I)          (II)                (III)          (IV)                 C
6911 C                                                                              C
6912 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6913 C                                                                              C
6914 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6915 C                                                                              C
6916 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6917 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6918 cd        eello5=0.0d0
6919 cd        return
6920 cd      endif
6921 cd      write (iout,*)
6922 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6923 cd     &   ' and',k,l
6924       itk=itortyp(itype(k))
6925       itl=itortyp(itype(l))
6926       itj=itortyp(itype(j))
6927       eello5_1=0.0d0
6928       eello5_2=0.0d0
6929       eello5_3=0.0d0
6930       eello5_4=0.0d0
6931 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6932 cd     &   eel5_3_num,eel5_4_num)
6933       do iii=1,2
6934         do kkk=1,5
6935           do lll=1,3
6936             derx(lll,kkk,iii)=0.0d0
6937           enddo
6938         enddo
6939       enddo
6940 cd      eij=facont_hb(jj,i)
6941 cd      ekl=facont_hb(kk,k)
6942 cd      ekont=eij*ekl
6943 cd      write (iout,*)'Contacts have occurred for peptide groups',
6944 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6945 cd      goto 1111
6946 C Contribution from the graph I.
6947 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6948 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6949       call transpose2(EUg(1,1,k),auxmat(1,1))
6950       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6951       vv(1)=pizda(1,1)-pizda(2,2)
6952       vv(2)=pizda(1,2)+pizda(2,1)
6953       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6954      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6955       if (calc_grad) then
6956 C Explicit gradient in virtual-dihedral angles.
6957       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6958      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6959      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6960       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6961       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6962       vv(1)=pizda(1,1)-pizda(2,2)
6963       vv(2)=pizda(1,2)+pizda(2,1)
6964       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6965      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6966      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6967       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6968       vv(1)=pizda(1,1)-pizda(2,2)
6969       vv(2)=pizda(1,2)+pizda(2,1)
6970       if (l.eq.j+1) then
6971         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6972      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6973      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6974       else
6975         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6976      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6977      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6978       endif
6979 C Cartesian gradient
6980       do iii=1,2
6981         do kkk=1,5
6982           do lll=1,3
6983             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6984      &        pizda(1,1))
6985             vv(1)=pizda(1,1)-pizda(2,2)
6986             vv(2)=pizda(1,2)+pizda(2,1)
6987             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6988      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6989      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6990           enddo
6991         enddo
6992       enddo
6993 c      goto 1112
6994       endif
6995 c1111  continue
6996 C Contribution from graph II
6997       call transpose2(EE(1,1,itk),auxmat(1,1))
6998       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6999       vv(1)=pizda(1,1)+pizda(2,2)
7000       vv(2)=pizda(2,1)-pizda(1,2)
7001       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7002      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7003       if (calc_grad) then
7004 C Explicit gradient in virtual-dihedral angles.
7005       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7006      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7007       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7008       vv(1)=pizda(1,1)+pizda(2,2)
7009       vv(2)=pizda(2,1)-pizda(1,2)
7010       if (l.eq.j+1) then
7011         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7012      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7013      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7014       else
7015         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7016      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7017      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7018       endif
7019 C Cartesian gradient
7020       do iii=1,2
7021         do kkk=1,5
7022           do lll=1,3
7023             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7024      &        pizda(1,1))
7025             vv(1)=pizda(1,1)+pizda(2,2)
7026             vv(2)=pizda(2,1)-pizda(1,2)
7027             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7028      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7029      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7030           enddo
7031         enddo
7032       enddo
7033 cd      goto 1112
7034       endif
7035 cd1111  continue
7036       if (l.eq.j+1) then
7037 cd        goto 1110
7038 C Parallel orientation
7039 C Contribution from graph III
7040         call transpose2(EUg(1,1,l),auxmat(1,1))
7041         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7042         vv(1)=pizda(1,1)-pizda(2,2)
7043         vv(2)=pizda(1,2)+pizda(2,1)
7044         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7045      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7046         if (calc_grad) then
7047 C Explicit gradient in virtual-dihedral angles.
7048         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7049      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7050      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7051         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7052         vv(1)=pizda(1,1)-pizda(2,2)
7053         vv(2)=pizda(1,2)+pizda(2,1)
7054         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7055      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7056      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7057         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7058         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7059         vv(1)=pizda(1,1)-pizda(2,2)
7060         vv(2)=pizda(1,2)+pizda(2,1)
7061         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7062      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7063      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7064 C Cartesian gradient
7065         do iii=1,2
7066           do kkk=1,5
7067             do lll=1,3
7068               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7069      &          pizda(1,1))
7070               vv(1)=pizda(1,1)-pizda(2,2)
7071               vv(2)=pizda(1,2)+pizda(2,1)
7072               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7073      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7074      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7075             enddo
7076           enddo
7077         enddo
7078 cd        goto 1112
7079         endif
7080 C Contribution from graph IV
7081 cd1110    continue
7082         call transpose2(EE(1,1,itl),auxmat(1,1))
7083         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7084         vv(1)=pizda(1,1)+pizda(2,2)
7085         vv(2)=pizda(2,1)-pizda(1,2)
7086         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7087      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7088         if (calc_grad) then
7089 C Explicit gradient in virtual-dihedral angles.
7090         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7091      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7092         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7093         vv(1)=pizda(1,1)+pizda(2,2)
7094         vv(2)=pizda(2,1)-pizda(1,2)
7095         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7096      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7097      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7098 C Cartesian gradient
7099         do iii=1,2
7100           do kkk=1,5
7101             do lll=1,3
7102               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7103      &          pizda(1,1))
7104               vv(1)=pizda(1,1)+pizda(2,2)
7105               vv(2)=pizda(2,1)-pizda(1,2)
7106               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7107      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7108      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7109             enddo
7110           enddo
7111         enddo
7112         endif
7113       else
7114 C Antiparallel orientation
7115 C Contribution from graph III
7116 c        goto 1110
7117         call transpose2(EUg(1,1,j),auxmat(1,1))
7118         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7119         vv(1)=pizda(1,1)-pizda(2,2)
7120         vv(2)=pizda(1,2)+pizda(2,1)
7121         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7122      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7123         if (calc_grad) then
7124 C Explicit gradient in virtual-dihedral angles.
7125         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7126      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7127      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7128         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7129         vv(1)=pizda(1,1)-pizda(2,2)
7130         vv(2)=pizda(1,2)+pizda(2,1)
7131         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7132      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7133      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7134         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7135         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7136         vv(1)=pizda(1,1)-pizda(2,2)
7137         vv(2)=pizda(1,2)+pizda(2,1)
7138         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7139      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7140      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7141 C Cartesian gradient
7142         do iii=1,2
7143           do kkk=1,5
7144             do lll=1,3
7145               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7146      &          pizda(1,1))
7147               vv(1)=pizda(1,1)-pizda(2,2)
7148               vv(2)=pizda(1,2)+pizda(2,1)
7149               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7150      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7151      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7152             enddo
7153           enddo
7154         enddo
7155 cd        goto 1112
7156         endif
7157 C Contribution from graph IV
7158 1110    continue
7159         call transpose2(EE(1,1,itj),auxmat(1,1))
7160         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7161         vv(1)=pizda(1,1)+pizda(2,2)
7162         vv(2)=pizda(2,1)-pizda(1,2)
7163         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7164      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7165         if (calc_grad) then
7166 C Explicit gradient in virtual-dihedral angles.
7167         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7168      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7169         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7170         vv(1)=pizda(1,1)+pizda(2,2)
7171         vv(2)=pizda(2,1)-pizda(1,2)
7172         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7173      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7174      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7175 C Cartesian gradient
7176         do iii=1,2
7177           do kkk=1,5
7178             do lll=1,3
7179               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7180      &          pizda(1,1))
7181               vv(1)=pizda(1,1)+pizda(2,2)
7182               vv(2)=pizda(2,1)-pizda(1,2)
7183               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7184      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7185      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7186             enddo
7187           enddo
7188         enddo
7189       endif
7190       endif
7191 1112  continue
7192       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7193 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7194 cd        write (2,*) 'ijkl',i,j,k,l
7195 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7196 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7197 cd      endif
7198 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7199 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7200 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7201 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7202       if (calc_grad) then
7203       if (j.lt.nres-1) then
7204         j1=j+1
7205         j2=j-1
7206       else
7207         j1=j-1
7208         j2=j-2
7209       endif
7210       if (l.lt.nres-1) then
7211         l1=l+1
7212         l2=l-1
7213       else
7214         l1=l-1
7215         l2=l-2
7216       endif
7217 cd      eij=1.0d0
7218 cd      ekl=1.0d0
7219 cd      ekont=1.0d0
7220 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7221       do ll=1,3
7222         ggg1(ll)=eel5*g_contij(ll,1)
7223         ggg2(ll)=eel5*g_contij(ll,2)
7224 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7225         ghalf=0.5d0*ggg1(ll)
7226 cd        ghalf=0.0d0
7227         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7228         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7229         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7230         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7231 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7232         ghalf=0.5d0*ggg2(ll)
7233 cd        ghalf=0.0d0
7234         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7235         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7236         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7237         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7238       enddo
7239 cd      goto 1112
7240       do m=i+1,j-1
7241         do ll=1,3
7242 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7243           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7244         enddo
7245       enddo
7246       do m=k+1,l-1
7247         do ll=1,3
7248 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7249           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7250         enddo
7251       enddo
7252 c1112  continue
7253       do m=i+2,j2
7254         do ll=1,3
7255           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7256         enddo
7257       enddo
7258       do m=k+2,l2
7259         do ll=1,3
7260           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7261         enddo
7262       enddo
7263 cd      do iii=1,nres-3
7264 cd        write (2,*) iii,g_corr5_loc(iii)
7265 cd      enddo
7266       endif
7267       eello5=ekont*eel5
7268 cd      write (2,*) 'ekont',ekont
7269 cd      write (iout,*) 'eello5',ekont*eel5
7270       return
7271       end
7272 c--------------------------------------------------------------------------
7273       double precision function eello6(i,j,k,l,jj,kk)
7274       implicit real*8 (a-h,o-z)
7275       include 'DIMENSIONS'
7276       include 'sizesclu.dat'
7277       include 'COMMON.IOUNITS'
7278       include 'COMMON.CHAIN'
7279       include 'COMMON.DERIV'
7280       include 'COMMON.INTERACT'
7281       include 'COMMON.CONTACTS'
7282       include 'COMMON.TORSION'
7283       include 'COMMON.VAR'
7284       include 'COMMON.GEO'
7285       include 'COMMON.FFIELD'
7286       double precision ggg1(3),ggg2(3)
7287 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7288 cd        eello6=0.0d0
7289 cd        return
7290 cd      endif
7291 cd      write (iout,*)
7292 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7293 cd     &   ' and',k,l
7294       eello6_1=0.0d0
7295       eello6_2=0.0d0
7296       eello6_3=0.0d0
7297       eello6_4=0.0d0
7298       eello6_5=0.0d0
7299       eello6_6=0.0d0
7300 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7301 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7302       do iii=1,2
7303         do kkk=1,5
7304           do lll=1,3
7305             derx(lll,kkk,iii)=0.0d0
7306           enddo
7307         enddo
7308       enddo
7309 cd      eij=facont_hb(jj,i)
7310 cd      ekl=facont_hb(kk,k)
7311 cd      ekont=eij*ekl
7312 cd      eij=1.0d0
7313 cd      ekl=1.0d0
7314 cd      ekont=1.0d0
7315       if (l.eq.j+1) then
7316         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7317         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7318         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7319         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7320         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7321         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7322       else
7323         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7324         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7325         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7326         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7327         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7328           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7329         else
7330           eello6_5=0.0d0
7331         endif
7332         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7333       endif
7334 C If turn contributions are considered, they will be handled separately.
7335       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7336 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7337 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7338 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7339 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7340 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7341 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7342 cd      goto 1112
7343       if (calc_grad) then
7344       if (j.lt.nres-1) then
7345         j1=j+1
7346         j2=j-1
7347       else
7348         j1=j-1
7349         j2=j-2
7350       endif
7351       if (l.lt.nres-1) then
7352         l1=l+1
7353         l2=l-1
7354       else
7355         l1=l-1
7356         l2=l-2
7357       endif
7358       do ll=1,3
7359         ggg1(ll)=eel6*g_contij(ll,1)
7360         ggg2(ll)=eel6*g_contij(ll,2)
7361 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7362         ghalf=0.5d0*ggg1(ll)
7363 cd        ghalf=0.0d0
7364         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7365         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7366         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7367         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7368         ghalf=0.5d0*ggg2(ll)
7369 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7370 cd        ghalf=0.0d0
7371         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7372         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7373         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7374         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7375       enddo
7376 cd      goto 1112
7377       do m=i+1,j-1
7378         do ll=1,3
7379 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7380           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7381         enddo
7382       enddo
7383       do m=k+1,l-1
7384         do ll=1,3
7385 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7386           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7387         enddo
7388       enddo
7389 1112  continue
7390       do m=i+2,j2
7391         do ll=1,3
7392           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7393         enddo
7394       enddo
7395       do m=k+2,l2
7396         do ll=1,3
7397           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7398         enddo
7399       enddo
7400 cd      do iii=1,nres-3
7401 cd        write (2,*) iii,g_corr6_loc(iii)
7402 cd      enddo
7403       endif
7404       eello6=ekont*eel6
7405 cd      write (2,*) 'ekont',ekont
7406 cd      write (iout,*) 'eello6',ekont*eel6
7407       return
7408       end
7409 c--------------------------------------------------------------------------
7410       double precision function eello6_graph1(i,j,k,l,imat,swap)
7411       implicit real*8 (a-h,o-z)
7412       include 'DIMENSIONS'
7413       include 'sizesclu.dat'
7414       include 'COMMON.IOUNITS'
7415       include 'COMMON.CHAIN'
7416       include 'COMMON.DERIV'
7417       include 'COMMON.INTERACT'
7418       include 'COMMON.CONTACTS'
7419       include 'COMMON.TORSION'
7420       include 'COMMON.VAR'
7421       include 'COMMON.GEO'
7422       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7423       logical swap
7424       logical lprn
7425       common /kutas/ lprn
7426 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7427 C                                                                              C
7428 C      Parallel       Antiparallel                                             C
7429 C                                                                              C
7430 C          o             o                                                     C
7431 C         /l\           /j\                                                    C
7432 C        /   \         /   \                                                   C
7433 C       /| o |         | o |\                                                  C
7434 C     \ j|/k\|  /   \  |/k\|l /                                                C
7435 C      \ /   \ /     \ /   \ /                                                 C
7436 C       o     o       o     o                                                  C
7437 C       i             i                                                        C
7438 C                                                                              C
7439 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7440       itk=itortyp(itype(k))
7441       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7442       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7443       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7444       call transpose2(EUgC(1,1,k),auxmat(1,1))
7445       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7446       vv1(1)=pizda1(1,1)-pizda1(2,2)
7447       vv1(2)=pizda1(1,2)+pizda1(2,1)
7448       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7449       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7450       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7451       s5=scalar2(vv(1),Dtobr2(1,i))
7452 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7453       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7454       if (.not. calc_grad) return
7455       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7456      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7457      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7458      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7459      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7460      & +scalar2(vv(1),Dtobr2der(1,i)))
7461       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7462       vv1(1)=pizda1(1,1)-pizda1(2,2)
7463       vv1(2)=pizda1(1,2)+pizda1(2,1)
7464       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7465       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7466       if (l.eq.j+1) then
7467         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7468      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7469      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7470      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7471      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7472       else
7473         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7474      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7475      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7476      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7477      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7478       endif
7479       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7480       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7481       vv1(1)=pizda1(1,1)-pizda1(2,2)
7482       vv1(2)=pizda1(1,2)+pizda1(2,1)
7483       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7484      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7485      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7486      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7487       do iii=1,2
7488         if (swap) then
7489           ind=3-iii
7490         else
7491           ind=iii
7492         endif
7493         do kkk=1,5
7494           do lll=1,3
7495             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7496             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7497             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7498             call transpose2(EUgC(1,1,k),auxmat(1,1))
7499             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7500      &        pizda1(1,1))
7501             vv1(1)=pizda1(1,1)-pizda1(2,2)
7502             vv1(2)=pizda1(1,2)+pizda1(2,1)
7503             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7504             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7505      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7506             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7507      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7508             s5=scalar2(vv(1),Dtobr2(1,i))
7509             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7510           enddo
7511         enddo
7512       enddo
7513       return
7514       end
7515 c----------------------------------------------------------------------------
7516       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7517       implicit real*8 (a-h,o-z)
7518       include 'DIMENSIONS'
7519       include 'sizesclu.dat'
7520       include 'COMMON.IOUNITS'
7521       include 'COMMON.CHAIN'
7522       include 'COMMON.DERIV'
7523       include 'COMMON.INTERACT'
7524       include 'COMMON.CONTACTS'
7525       include 'COMMON.TORSION'
7526       include 'COMMON.VAR'
7527       include 'COMMON.GEO'
7528       logical swap
7529       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7530      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7531       logical lprn
7532       common /kutas/ lprn
7533 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7534 C                                                                              C
7535 C      Parallel       Antiparallel                                             C
7536 C                                                                              C
7537 C          o             o                                                     C
7538 C     \   /l\           /j\   /                                                C
7539 C      \ /   \         /   \ /                                                 C
7540 C       o| o |         | o |o                                                  C
7541 C     \ j|/k\|      \  |/k\|l                                                  C
7542 C      \ /   \       \ /   \                                                   C
7543 C       o             o                                                        C
7544 C       i             i                                                        C
7545 C                                                                              C
7546 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7547 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7548 C AL 7/4/01 s1 would occur in the sixth-order moment,
7549 C           but not in a cluster cumulant
7550 #ifdef MOMENT
7551       s1=dip(1,jj,i)*dip(1,kk,k)
7552 #endif
7553       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7554       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7555       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7556       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7557       call transpose2(EUg(1,1,k),auxmat(1,1))
7558       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7559       vv(1)=pizda(1,1)-pizda(2,2)
7560       vv(2)=pizda(1,2)+pizda(2,1)
7561       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7562 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7563 #ifdef MOMENT
7564       eello6_graph2=-(s1+s2+s3+s4)
7565 #else
7566       eello6_graph2=-(s2+s3+s4)
7567 #endif
7568 c      eello6_graph2=-s3
7569       if (.not. calc_grad) return
7570 C Derivatives in gamma(i-1)
7571       if (i.gt.1) then
7572 #ifdef MOMENT
7573         s1=dipderg(1,jj,i)*dip(1,kk,k)
7574 #endif
7575         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7576         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7577         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7578         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7579 #ifdef MOMENT
7580         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7581 #else
7582         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7583 #endif
7584 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7585       endif
7586 C Derivatives in gamma(k-1)
7587 #ifdef MOMENT
7588       s1=dip(1,jj,i)*dipderg(1,kk,k)
7589 #endif
7590       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7591       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7592       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7593       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7594       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7595       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7596       vv(1)=pizda(1,1)-pizda(2,2)
7597       vv(2)=pizda(1,2)+pizda(2,1)
7598       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7599 #ifdef MOMENT
7600       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7601 #else
7602       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7603 #endif
7604 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7605 C Derivatives in gamma(j-1) or gamma(l-1)
7606       if (j.gt.1) then
7607 #ifdef MOMENT
7608         s1=dipderg(3,jj,i)*dip(1,kk,k)
7609 #endif
7610         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7611         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7612         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7613         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7614         vv(1)=pizda(1,1)-pizda(2,2)
7615         vv(2)=pizda(1,2)+pizda(2,1)
7616         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7617 #ifdef MOMENT
7618         if (swap) then
7619           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7620         else
7621           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7622         endif
7623 #endif
7624         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7625 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7626       endif
7627 C Derivatives in gamma(l-1) or gamma(j-1)
7628       if (l.gt.1) then
7629 #ifdef MOMENT
7630         s1=dip(1,jj,i)*dipderg(3,kk,k)
7631 #endif
7632         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7633         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7634         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7635         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7636         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7637         vv(1)=pizda(1,1)-pizda(2,2)
7638         vv(2)=pizda(1,2)+pizda(2,1)
7639         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7640 #ifdef MOMENT
7641         if (swap) then
7642           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7643         else
7644           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7645         endif
7646 #endif
7647         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7648 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7649       endif
7650 C Cartesian derivatives.
7651       if (lprn) then
7652         write (2,*) 'In eello6_graph2'
7653         do iii=1,2
7654           write (2,*) 'iii=',iii
7655           do kkk=1,5
7656             write (2,*) 'kkk=',kkk
7657             do jjj=1,2
7658               write (2,'(3(2f10.5),5x)')
7659      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7660             enddo
7661           enddo
7662         enddo
7663       endif
7664       do iii=1,2
7665         do kkk=1,5
7666           do lll=1,3
7667 #ifdef MOMENT
7668             if (iii.eq.1) then
7669               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7670             else
7671               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7672             endif
7673 #endif
7674             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7675      &        auxvec(1))
7676             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7677             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7678      &        auxvec(1))
7679             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7680             call transpose2(EUg(1,1,k),auxmat(1,1))
7681             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7682      &        pizda(1,1))
7683             vv(1)=pizda(1,1)-pizda(2,2)
7684             vv(2)=pizda(1,2)+pizda(2,1)
7685             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7686 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7687 #ifdef MOMENT
7688             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7689 #else
7690             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7691 #endif
7692             if (swap) then
7693               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7694             else
7695               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7696             endif
7697           enddo
7698         enddo
7699       enddo
7700       return
7701       end
7702 c----------------------------------------------------------------------------
7703       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7704       implicit real*8 (a-h,o-z)
7705       include 'DIMENSIONS'
7706       include 'sizesclu.dat'
7707       include 'COMMON.IOUNITS'
7708       include 'COMMON.CHAIN'
7709       include 'COMMON.DERIV'
7710       include 'COMMON.INTERACT'
7711       include 'COMMON.CONTACTS'
7712       include 'COMMON.TORSION'
7713       include 'COMMON.VAR'
7714       include 'COMMON.GEO'
7715       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7716       logical swap
7717 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7718 C                                                                              C
7719 C      Parallel       Antiparallel                                             C
7720 C                                                                              C
7721 C          o             o                                                     C
7722 C         /l\   /   \   /j\                                                    C
7723 C        /   \ /     \ /   \                                                   C
7724 C       /| o |o       o| o |\                                                  C
7725 C       j|/k\|  /      |/k\|l /                                                C
7726 C        /   \ /       /   \ /                                                 C
7727 C       /     o       /     o                                                  C
7728 C       i             i                                                        C
7729 C                                                                              C
7730 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7731 C
7732 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7733 C           energy moment and not to the cluster cumulant.
7734       iti=itortyp(itype(i))
7735 c      if (j.lt.nres-1) then
7736       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7737         itj1=itortyp(itype(j+1))
7738       else
7739         itj1=ntortyp+1
7740       endif
7741       itk=itortyp(itype(k))
7742       itk1=itortyp(itype(k+1))
7743 c      if (l.lt.nres-1) then
7744       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7745         itl1=itortyp(itype(l+1))
7746       else
7747         itl1=ntortyp+1
7748       endif
7749 #ifdef MOMENT
7750       s1=dip(4,jj,i)*dip(4,kk,k)
7751 #endif
7752       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7753       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7754       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7755       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7756       call transpose2(EE(1,1,itk),auxmat(1,1))
7757       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7758       vv(1)=pizda(1,1)+pizda(2,2)
7759       vv(2)=pizda(2,1)-pizda(1,2)
7760       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7761 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7762 #ifdef MOMENT
7763       eello6_graph3=-(s1+s2+s3+s4)
7764 #else
7765       eello6_graph3=-(s2+s3+s4)
7766 #endif
7767 c      eello6_graph3=-s4
7768       if (.not. calc_grad) return
7769 C Derivatives in gamma(k-1)
7770       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7771       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7772       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7773       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7774 C Derivatives in gamma(l-1)
7775       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7776       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7777       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7778       vv(1)=pizda(1,1)+pizda(2,2)
7779       vv(2)=pizda(2,1)-pizda(1,2)
7780       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7781       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7782 C Cartesian derivatives.
7783       do iii=1,2
7784         do kkk=1,5
7785           do lll=1,3
7786 #ifdef MOMENT
7787             if (iii.eq.1) then
7788               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7789             else
7790               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7791             endif
7792 #endif
7793             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7794      &        auxvec(1))
7795             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7796             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7797      &        auxvec(1))
7798             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7799             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7800      &        pizda(1,1))
7801             vv(1)=pizda(1,1)+pizda(2,2)
7802             vv(2)=pizda(2,1)-pizda(1,2)
7803             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7804 #ifdef MOMENT
7805             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7806 #else
7807             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7808 #endif
7809             if (swap) then
7810               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7811             else
7812               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7813             endif
7814 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7815           enddo
7816         enddo
7817       enddo
7818       return
7819       end
7820 c----------------------------------------------------------------------------
7821       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7822       implicit real*8 (a-h,o-z)
7823       include 'DIMENSIONS'
7824       include 'sizesclu.dat'
7825       include 'COMMON.IOUNITS'
7826       include 'COMMON.CHAIN'
7827       include 'COMMON.DERIV'
7828       include 'COMMON.INTERACT'
7829       include 'COMMON.CONTACTS'
7830       include 'COMMON.TORSION'
7831       include 'COMMON.VAR'
7832       include 'COMMON.GEO'
7833       include 'COMMON.FFIELD'
7834       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7835      & auxvec1(2),auxmat1(2,2)
7836       logical swap
7837 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7838 C                                                                              C
7839 C      Parallel       Antiparallel                                             C
7840 C                                                                              C
7841 C          o             o                                                     C
7842 C         /l\   /   \   /j\                                                    C
7843 C        /   \ /     \ /   \                                                   C
7844 C       /| o |o       o| o |\                                                  C
7845 C     \ j|/k\|      \  |/k\|l                                                  C
7846 C      \ /   \       \ /   \                                                   C
7847 C       o     \       o     \                                                  C
7848 C       i             i                                                        C
7849 C                                                                              C
7850 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7851 C
7852 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7853 C           energy moment and not to the cluster cumulant.
7854 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7855       iti=itortyp(itype(i))
7856       itj=itortyp(itype(j))
7857 c      if (j.lt.nres-1) then
7858       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7859         itj1=itortyp(itype(j+1))
7860       else
7861         itj1=ntortyp+1
7862       endif
7863       itk=itortyp(itype(k))
7864 c      if (k.lt.nres-1) then
7865       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7866         itk1=itortyp(itype(k+1))
7867       else
7868         itk1=ntortyp+1
7869       endif
7870       itl=itortyp(itype(l))
7871       if (l.lt.nres-1) then
7872         itl1=itortyp(itype(l+1))
7873       else
7874         itl1=ntortyp+1
7875       endif
7876 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7877 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7878 cd     & ' itl',itl,' itl1',itl1
7879 #ifdef MOMENT
7880       if (imat.eq.1) then
7881         s1=dip(3,jj,i)*dip(3,kk,k)
7882       else
7883         s1=dip(2,jj,j)*dip(2,kk,l)
7884       endif
7885 #endif
7886       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7887       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7888       if (j.eq.l+1) then
7889         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7890         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7891       else
7892         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7893         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7894       endif
7895       call transpose2(EUg(1,1,k),auxmat(1,1))
7896       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7897       vv(1)=pizda(1,1)-pizda(2,2)
7898       vv(2)=pizda(2,1)+pizda(1,2)
7899       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7900 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7901 #ifdef MOMENT
7902       eello6_graph4=-(s1+s2+s3+s4)
7903 #else
7904       eello6_graph4=-(s2+s3+s4)
7905 #endif
7906       if (.not. calc_grad) return
7907 C Derivatives in gamma(i-1)
7908       if (i.gt.1) then
7909 #ifdef MOMENT
7910         if (imat.eq.1) then
7911           s1=dipderg(2,jj,i)*dip(3,kk,k)
7912         else
7913           s1=dipderg(4,jj,j)*dip(2,kk,l)
7914         endif
7915 #endif
7916         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7917         if (j.eq.l+1) then
7918           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7919           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7920         else
7921           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7922           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7923         endif
7924         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7925         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7926 cd          write (2,*) 'turn6 derivatives'
7927 #ifdef MOMENT
7928           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7929 #else
7930           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7931 #endif
7932         else
7933 #ifdef MOMENT
7934           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7935 #else
7936           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7937 #endif
7938         endif
7939       endif
7940 C Derivatives in gamma(k-1)
7941 #ifdef MOMENT
7942       if (imat.eq.1) then
7943         s1=dip(3,jj,i)*dipderg(2,kk,k)
7944       else
7945         s1=dip(2,jj,j)*dipderg(4,kk,l)
7946       endif
7947 #endif
7948       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7949       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7950       if (j.eq.l+1) then
7951         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7952         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7953       else
7954         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7955         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7956       endif
7957       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7958       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7959       vv(1)=pizda(1,1)-pizda(2,2)
7960       vv(2)=pizda(2,1)+pizda(1,2)
7961       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7962       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7963 #ifdef MOMENT
7964         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7965 #else
7966         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7967 #endif
7968       else
7969 #ifdef MOMENT
7970         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7971 #else
7972         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7973 #endif
7974       endif
7975 C Derivatives in gamma(j-1) or gamma(l-1)
7976       if (l.eq.j+1 .and. l.gt.1) then
7977         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7978         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7979         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7980         vv(1)=pizda(1,1)-pizda(2,2)
7981         vv(2)=pizda(2,1)+pizda(1,2)
7982         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7983         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7984       else if (j.gt.1) then
7985         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7986         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7987         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7988         vv(1)=pizda(1,1)-pizda(2,2)
7989         vv(2)=pizda(2,1)+pizda(1,2)
7990         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7991         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7992           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7993         else
7994           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7995         endif
7996       endif
7997 C Cartesian derivatives.
7998       do iii=1,2
7999         do kkk=1,5
8000           do lll=1,3
8001 #ifdef MOMENT
8002             if (iii.eq.1) then
8003               if (imat.eq.1) then
8004                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8005               else
8006                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8007               endif
8008             else
8009               if (imat.eq.1) then
8010                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8011               else
8012                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8013               endif
8014             endif
8015 #endif
8016             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8017      &        auxvec(1))
8018             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8019             if (j.eq.l+1) then
8020               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8021      &          b1(1,itj1),auxvec(1))
8022               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8023             else
8024               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8025      &          b1(1,itl1),auxvec(1))
8026               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8027             endif
8028             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8029      &        pizda(1,1))
8030             vv(1)=pizda(1,1)-pizda(2,2)
8031             vv(2)=pizda(2,1)+pizda(1,2)
8032             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8033             if (swap) then
8034               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8035 #ifdef MOMENT
8036                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8037      &             -(s1+s2+s4)
8038 #else
8039                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8040      &             -(s2+s4)
8041 #endif
8042                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8043               else
8044 #ifdef MOMENT
8045                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8046 #else
8047                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8048 #endif
8049                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8050               endif
8051             else
8052 #ifdef MOMENT
8053               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8054 #else
8055               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8056 #endif
8057               if (l.eq.j+1) then
8058                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8059               else
8060                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8061               endif
8062             endif
8063           enddo
8064         enddo
8065       enddo
8066       return
8067       end
8068 c----------------------------------------------------------------------------
8069       double precision function eello_turn6(i,jj,kk)
8070       implicit real*8 (a-h,o-z)
8071       include 'DIMENSIONS'
8072       include 'sizesclu.dat'
8073       include 'COMMON.IOUNITS'
8074       include 'COMMON.CHAIN'
8075       include 'COMMON.DERIV'
8076       include 'COMMON.INTERACT'
8077       include 'COMMON.CONTACTS'
8078       include 'COMMON.TORSION'
8079       include 'COMMON.VAR'
8080       include 'COMMON.GEO'
8081       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8082      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8083      &  ggg1(3),ggg2(3)
8084       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8085      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8086 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8087 C           the respective energy moment and not to the cluster cumulant.
8088       eello_turn6=0.0d0
8089       j=i+4
8090       k=i+1
8091       l=i+3
8092       iti=itortyp(itype(i))
8093       itk=itortyp(itype(k))
8094       itk1=itortyp(itype(k+1))
8095       itl=itortyp(itype(l))
8096       itj=itortyp(itype(j))
8097 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8098 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8099 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8100 cd        eello6=0.0d0
8101 cd        return
8102 cd      endif
8103 cd      write (iout,*)
8104 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8105 cd     &   ' and',k,l
8106 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8107       do iii=1,2
8108         do kkk=1,5
8109           do lll=1,3
8110             derx_turn(lll,kkk,iii)=0.0d0
8111           enddo
8112         enddo
8113       enddo
8114 cd      eij=1.0d0
8115 cd      ekl=1.0d0
8116 cd      ekont=1.0d0
8117       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8118 cd      eello6_5=0.0d0
8119 cd      write (2,*) 'eello6_5',eello6_5
8120 #ifdef MOMENT
8121       call transpose2(AEA(1,1,1),auxmat(1,1))
8122       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8123       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8124       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8125 #else
8126       s1 = 0.0d0
8127 #endif
8128       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8129       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8130       s2 = scalar2(b1(1,itk),vtemp1(1))
8131 #ifdef MOMENT
8132       call transpose2(AEA(1,1,2),atemp(1,1))
8133       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8134       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8135       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8136 #else
8137       s8=0.0d0
8138 #endif
8139       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8140       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8141       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8142 #ifdef MOMENT
8143       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8144       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8145       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8146       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8147       ss13 = scalar2(b1(1,itk),vtemp4(1))
8148       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8149 #else
8150       s13=0.0d0
8151 #endif
8152 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8153 c      s1=0.0d0
8154 c      s2=0.0d0
8155 c      s8=0.0d0
8156 c      s12=0.0d0
8157 c      s13=0.0d0
8158       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8159       if (calc_grad) then
8160 C Derivatives in gamma(i+2)
8161 #ifdef MOMENT
8162       call transpose2(AEA(1,1,1),auxmatd(1,1))
8163       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8164       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8165       call transpose2(AEAderg(1,1,2),atempd(1,1))
8166       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8167       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8168 #else
8169       s8d=0.0d0
8170 #endif
8171       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8172       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8173       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8174 c      s1d=0.0d0
8175 c      s2d=0.0d0
8176 c      s8d=0.0d0
8177 c      s12d=0.0d0
8178 c      s13d=0.0d0
8179       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8180 C Derivatives in gamma(i+3)
8181 #ifdef MOMENT
8182       call transpose2(AEA(1,1,1),auxmatd(1,1))
8183       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8184       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8185       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8186 #else
8187       s1d=0.0d0
8188 #endif
8189       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8190       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8191       s2d = scalar2(b1(1,itk),vtemp1d(1))
8192 #ifdef MOMENT
8193       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8194       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8195 #endif
8196       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8197 #ifdef MOMENT
8198       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8199       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8200       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8201 #else
8202       s13d=0.0d0
8203 #endif
8204 c      s1d=0.0d0
8205 c      s2d=0.0d0
8206 c      s8d=0.0d0
8207 c      s12d=0.0d0
8208 c      s13d=0.0d0
8209 #ifdef MOMENT
8210       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8211      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8212 #else
8213       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8214      &               -0.5d0*ekont*(s2d+s12d)
8215 #endif
8216 C Derivatives in gamma(i+4)
8217       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8218       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8219       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8220 #ifdef MOMENT
8221       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8222       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8223       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8224 #else
8225       s13d = 0.0d0
8226 #endif
8227 c      s1d=0.0d0
8228 c      s2d=0.0d0
8229 c      s8d=0.0d0
8230 C      s12d=0.0d0
8231 c      s13d=0.0d0
8232 #ifdef MOMENT
8233       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8234 #else
8235       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8236 #endif
8237 C Derivatives in gamma(i+5)
8238 #ifdef MOMENT
8239       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8240       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8241       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8242 #else
8243       s1d = 0.0d0
8244 #endif
8245       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8246       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8247       s2d = scalar2(b1(1,itk),vtemp1d(1))
8248 #ifdef MOMENT
8249       call transpose2(AEA(1,1,2),atempd(1,1))
8250       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8251       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8252 #else
8253       s8d = 0.0d0
8254 #endif
8255       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8256       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8257 #ifdef MOMENT
8258       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8259       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8260       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8261 #else
8262       s13d = 0.0d0
8263 #endif
8264 c      s1d=0.0d0
8265 c      s2d=0.0d0
8266 c      s8d=0.0d0
8267 c      s12d=0.0d0
8268 c      s13d=0.0d0
8269 #ifdef MOMENT
8270       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8271      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8272 #else
8273       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8274      &               -0.5d0*ekont*(s2d+s12d)
8275 #endif
8276 C Cartesian derivatives
8277       do iii=1,2
8278         do kkk=1,5
8279           do lll=1,3
8280 #ifdef MOMENT
8281             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8282             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8283             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8284 #else
8285             s1d = 0.0d0
8286 #endif
8287             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8288             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8289      &          vtemp1d(1))
8290             s2d = scalar2(b1(1,itk),vtemp1d(1))
8291 #ifdef MOMENT
8292             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8293             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8294             s8d = -(atempd(1,1)+atempd(2,2))*
8295      &           scalar2(cc(1,1,itl),vtemp2(1))
8296 #else
8297             s8d = 0.0d0
8298 #endif
8299             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8300      &           auxmatd(1,1))
8301             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8302             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8303 c      s1d=0.0d0
8304 c      s2d=0.0d0
8305 c      s8d=0.0d0
8306 c      s12d=0.0d0
8307 c      s13d=0.0d0
8308 #ifdef MOMENT
8309             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8310      &        - 0.5d0*(s1d+s2d)
8311 #else
8312             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8313      &        - 0.5d0*s2d
8314 #endif
8315 #ifdef MOMENT
8316             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8317      &        - 0.5d0*(s8d+s12d)
8318 #else
8319             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8320      &        - 0.5d0*s12d
8321 #endif
8322           enddo
8323         enddo
8324       enddo
8325 #ifdef MOMENT
8326       do kkk=1,5
8327         do lll=1,3
8328           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8329      &      achuj_tempd(1,1))
8330           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8331           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8332           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8333           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8334           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8335      &      vtemp4d(1))
8336           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8337           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8338           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8339         enddo
8340       enddo
8341 #endif
8342 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8343 cd     &  16*eel_turn6_num
8344 cd      goto 1112
8345       if (j.lt.nres-1) then
8346         j1=j+1
8347         j2=j-1
8348       else
8349         j1=j-1
8350         j2=j-2
8351       endif
8352       if (l.lt.nres-1) then
8353         l1=l+1
8354         l2=l-1
8355       else
8356         l1=l-1
8357         l2=l-2
8358       endif
8359       do ll=1,3
8360         ggg1(ll)=eel_turn6*g_contij(ll,1)
8361         ggg2(ll)=eel_turn6*g_contij(ll,2)
8362         ghalf=0.5d0*ggg1(ll)
8363 cd        ghalf=0.0d0
8364         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8365      &    +ekont*derx_turn(ll,2,1)
8366         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8367         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8368      &    +ekont*derx_turn(ll,4,1)
8369         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8370         ghalf=0.5d0*ggg2(ll)
8371 cd        ghalf=0.0d0
8372         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8373      &    +ekont*derx_turn(ll,2,2)
8374         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8375         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8376      &    +ekont*derx_turn(ll,4,2)
8377         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8378       enddo
8379 cd      goto 1112
8380       do m=i+1,j-1
8381         do ll=1,3
8382           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8383         enddo
8384       enddo
8385       do m=k+1,l-1
8386         do ll=1,3
8387           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8388         enddo
8389       enddo
8390 1112  continue
8391       do m=i+2,j2
8392         do ll=1,3
8393           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8394         enddo
8395       enddo
8396       do m=k+2,l2
8397         do ll=1,3
8398           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8399         enddo
8400       enddo
8401 cd      do iii=1,nres-3
8402 cd        write (2,*) iii,g_corr6_loc(iii)
8403 cd      enddo
8404       endif
8405       eello_turn6=ekont*eel_turn6
8406 cd      write (2,*) 'ekont',ekont
8407 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8408       return
8409       end
8410 crc-------------------------------------------------
8411       SUBROUTINE MATVEC2(A1,V1,V2)
8412       implicit real*8 (a-h,o-z)
8413       include 'DIMENSIONS'
8414       DIMENSION A1(2,2),V1(2),V2(2)
8415 c      DO 1 I=1,2
8416 c        VI=0.0
8417 c        DO 3 K=1,2
8418 c    3     VI=VI+A1(I,K)*V1(K)
8419 c        Vaux(I)=VI
8420 c    1 CONTINUE
8421
8422       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8423       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8424
8425       v2(1)=vaux1
8426       v2(2)=vaux2
8427       END
8428 C---------------------------------------
8429       SUBROUTINE MATMAT2(A1,A2,A3)
8430       implicit real*8 (a-h,o-z)
8431       include 'DIMENSIONS'
8432       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8433 c      DIMENSION AI3(2,2)
8434 c        DO  J=1,2
8435 c          A3IJ=0.0
8436 c          DO K=1,2
8437 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8438 c          enddo
8439 c          A3(I,J)=A3IJ
8440 c       enddo
8441 c      enddo
8442
8443       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8444       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8445       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8446       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8447
8448       A3(1,1)=AI3_11
8449       A3(2,1)=AI3_21
8450       A3(1,2)=AI3_12
8451       A3(2,2)=AI3_22
8452       END
8453
8454 c-------------------------------------------------------------------------
8455       double precision function scalar2(u,v)
8456       implicit none
8457       double precision u(2),v(2)
8458       double precision sc
8459       integer i
8460       scalar2=u(1)*v(1)+u(2)*v(2)
8461       return
8462       end
8463
8464 C-----------------------------------------------------------------------------
8465
8466       subroutine transpose2(a,at)
8467       implicit none
8468       double precision a(2,2),at(2,2)
8469       at(1,1)=a(1,1)
8470       at(1,2)=a(2,1)
8471       at(2,1)=a(1,2)
8472       at(2,2)=a(2,2)
8473       return
8474       end
8475 c--------------------------------------------------------------------------
8476       subroutine transpose(n,a,at)
8477       implicit none
8478       integer n,i,j
8479       double precision a(n,n),at(n,n)
8480       do i=1,n
8481         do j=1,n
8482           at(j,i)=a(i,j)
8483         enddo
8484       enddo
8485       return
8486       end
8487 C---------------------------------------------------------------------------
8488       subroutine prodmat3(a1,a2,kk,transp,prod)
8489       implicit none
8490       integer i,j
8491       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8492       logical transp
8493 crc      double precision auxmat(2,2),prod_(2,2)
8494
8495       if (transp) then
8496 crc        call transpose2(kk(1,1),auxmat(1,1))
8497 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8498 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8499
8500            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8501      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8502            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8503      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8504            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8505      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8506            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8507      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8508
8509       else
8510 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8511 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8512
8513            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8514      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8515            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8516      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8517            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8518      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8519            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8520      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8521
8522       endif
8523 c      call transpose2(a2(1,1),a2t(1,1))
8524
8525 crc      print *,transp
8526 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8527 crc      print *,((prod(i,j),i=1,2),j=1,2)
8528
8529       return
8530       end
8531 C-----------------------------------------------------------------------------
8532       double precision function scalar(u,v)
8533       implicit none
8534       double precision u(3),v(3)
8535       double precision sc
8536       integer i
8537       sc=0.0d0
8538       do i=1,3
8539         sc=sc+u(i)*v(i)
8540       enddo
8541       scalar=sc
8542       return
8543       end
8544 C-----------------------------------------------------------------------
8545       double precision function sscale(r)
8546       double precision r,gamm
8547       include "COMMON.SPLITELE"
8548       if(r.lt.r_cut-rlamb) then
8549         sscale=1.0d0
8550       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8551         gamm=(r-(r_cut-rlamb))/rlamb
8552         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8553       else
8554         sscale=0d0
8555       endif
8556       return
8557       end
8558 C-----------------------------------------------------------------------
8559 C-----------------------------------------------------------------------
8560       double precision function sscagrad(r)
8561       double precision r,gamm
8562       include "COMMON.SPLITELE"
8563       if(r.lt.r_cut-rlamb) then
8564         sscagrad=0.0d0
8565       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8566         gamm=(r-(r_cut-rlamb))/rlamb
8567         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8568       else
8569         sscagrad=0.0d0
8570       endif
8571       return
8572       end
8573 C-----------------------------------------------------------------------
8574 C first for shielding is setting of function of side-chains
8575        subroutine set_shield_fac2
8576       implicit real*8 (a-h,o-z)
8577       include 'DIMENSIONS'
8578       include 'COMMON.CHAIN'
8579       include 'COMMON.DERIV'
8580       include 'COMMON.IOUNITS'
8581       include 'COMMON.SHIELD'
8582       include 'COMMON.INTERACT'
8583 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8584       double precision div77_81/0.974996043d0/,
8585      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8586
8587 C the vector between center of side_chain and peptide group
8588        double precision pep_side(3),long,side_calf(3),
8589      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8590      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8591 C the line belowe needs to be changed for FGPROC>1
8592       do i=1,nres-1
8593       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8594       ishield_list(i)=0
8595 Cif there two consequtive dummy atoms there is no peptide group between them
8596 C the line below has to be changed for FGPROC>1
8597       VolumeTotal=0.0
8598       do k=1,nres
8599        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8600        dist_pep_side=0.0
8601        dist_side_calf=0.0
8602        do j=1,3
8603 C first lets set vector conecting the ithe side-chain with kth side-chain
8604       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8605 C      pep_side(j)=2.0d0
8606 C and vector conecting the side-chain with its proper calfa
8607       side_calf(j)=c(j,k+nres)-c(j,k)
8608 C      side_calf(j)=2.0d0
8609       pept_group(j)=c(j,i)-c(j,i+1)
8610 C lets have their lenght
8611       dist_pep_side=pep_side(j)**2+dist_pep_side
8612       dist_side_calf=dist_side_calf+side_calf(j)**2
8613       dist_pept_group=dist_pept_group+pept_group(j)**2
8614       enddo
8615        dist_pep_side=dsqrt(dist_pep_side)
8616        dist_pept_group=dsqrt(dist_pept_group)
8617        dist_side_calf=dsqrt(dist_side_calf)
8618       do j=1,3
8619         pep_side_norm(j)=pep_side(j)/dist_pep_side
8620         side_calf_norm(j)=dist_side_calf
8621       enddo
8622 C now sscale fraction
8623        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8624 C       print *,buff_shield,"buff"
8625 C now sscale
8626         if (sh_frac_dist.le.0.0) cycle
8627 C If we reach here it means that this side chain reaches the shielding sphere
8628 C Lets add him to the list for gradient
8629         ishield_list(i)=ishield_list(i)+1
8630 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8631 C this list is essential otherwise problem would be O3
8632         shield_list(ishield_list(i),i)=k
8633 C Lets have the sscale value
8634         if (sh_frac_dist.gt.1.0) then
8635          scale_fac_dist=1.0d0
8636          do j=1,3
8637          sh_frac_dist_grad(j)=0.0d0
8638          enddo
8639         else
8640          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8641      &                   *(2.0d0*sh_frac_dist-3.0d0)
8642          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8643      &                  /dist_pep_side/buff_shield*0.5d0
8644 C remember for the final gradient multiply sh_frac_dist_grad(j)
8645 C for side_chain by factor -2 !
8646          do j=1,3
8647          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8648 C         sh_frac_dist_grad(j)=0.0d0
8649 C         scale_fac_dist=1.0d0
8650 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8651 C     &                    sh_frac_dist_grad(j)
8652          enddo
8653         endif
8654 C this is what is now we have the distance scaling now volume...
8655       short=short_r_sidechain(itype(k))
8656       long=long_r_sidechain(itype(k))
8657       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8658       sinthet=short/dist_pep_side*costhet
8659 C now costhet_grad
8660 C       costhet=0.6d0
8661 C       sinthet=0.8
8662        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8663 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8664 C     &             -short/dist_pep_side**2/costhet)
8665 C       costhet_fac=0.0d0
8666        do j=1,3
8667          costhet_grad(j)=costhet_fac*pep_side(j)
8668        enddo
8669 C remember for the final gradient multiply costhet_grad(j)
8670 C for side_chain by factor -2 !
8671 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8672 C pep_side0pept_group is vector multiplication
8673       pep_side0pept_group=0.0d0
8674       do j=1,3
8675       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8676       enddo
8677       cosalfa=(pep_side0pept_group/
8678      & (dist_pep_side*dist_side_calf))
8679       fac_alfa_sin=1.0d0-cosalfa**2
8680       fac_alfa_sin=dsqrt(fac_alfa_sin)
8681       rkprim=fac_alfa_sin*(long-short)+short
8682 C      rkprim=short
8683
8684 C now costhet_grad
8685        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8686 C       cosphi=0.6
8687        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8688        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8689      &      dist_pep_side**2)
8690 C       sinphi=0.8
8691        do j=1,3
8692          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8693      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8694      &*(long-short)/fac_alfa_sin*cosalfa/
8695      &((dist_pep_side*dist_side_calf))*
8696      &((side_calf(j))-cosalfa*
8697      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8698 C       cosphi_grad_long(j)=0.0d0
8699         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8700      &*(long-short)/fac_alfa_sin*cosalfa
8701      &/((dist_pep_side*dist_side_calf))*
8702      &(pep_side(j)-
8703      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8704 C       cosphi_grad_loc(j)=0.0d0
8705        enddo
8706 C      print *,sinphi,sinthet
8707       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
8708      &                    /VSolvSphere_div
8709 C     &                    *wshield
8710 C now the gradient...
8711       do j=1,3
8712       grad_shield(j,i)=grad_shield(j,i)
8713 C gradient po skalowaniu
8714      &                +(sh_frac_dist_grad(j)*VofOverlap
8715 C  gradient po costhet
8716      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
8717      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8718      &       sinphi/sinthet*costhet*costhet_grad(j)
8719      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8720      & )*wshield
8721 C grad_shield_side is Cbeta sidechain gradient
8722       grad_shield_side(j,ishield_list(i),i)=
8723      &        (sh_frac_dist_grad(j)*-2.0d0
8724      &        *VofOverlap
8725      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8726      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8727      &       sinphi/sinthet*costhet*costhet_grad(j)
8728      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8729      &       )*wshield
8730
8731        grad_shield_loc(j,ishield_list(i),i)=
8732      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8733      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
8734      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
8735      &        ))
8736      &        *wshield
8737       enddo
8738       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8739       enddo
8740       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
8741 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8742       enddo
8743       return
8744       end
8745 C first for shielding is setting of function of side-chains
8746        subroutine set_shield_fac
8747       implicit real*8 (a-h,o-z)
8748       include 'DIMENSIONS'
8749       include 'COMMON.CHAIN'
8750       include 'COMMON.DERIV'
8751       include 'COMMON.IOUNITS'
8752       include 'COMMON.SHIELD'
8753       include 'COMMON.INTERACT'
8754 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8755       double precision div77_81/0.974996043d0/,
8756      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8757
8758 C the vector between center of side_chain and peptide group
8759        double precision pep_side(3),long,side_calf(3),
8760      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8761      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8762 C the line belowe needs to be changed for FGPROC>1
8763       do i=1,nres-1
8764       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8765       ishield_list(i)=0
8766 Cif there two consequtive dummy atoms there is no peptide group between them
8767 C the line below has to be changed for FGPROC>1
8768       VolumeTotal=0.0
8769       do k=1,nres
8770        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8771        dist_pep_side=0.0
8772        dist_side_calf=0.0
8773        do j=1,3
8774 C first lets set vector conecting the ithe side-chain with kth side-chain
8775       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8776 C      pep_side(j)=2.0d0
8777 C and vector conecting the side-chain with its proper calfa
8778       side_calf(j)=c(j,k+nres)-c(j,k)
8779 C      side_calf(j)=2.0d0
8780       pept_group(j)=c(j,i)-c(j,i+1)
8781 C lets have their lenght
8782       dist_pep_side=pep_side(j)**2+dist_pep_side
8783       dist_side_calf=dist_side_calf+side_calf(j)**2
8784       dist_pept_group=dist_pept_group+pept_group(j)**2
8785       enddo
8786        dist_pep_side=dsqrt(dist_pep_side)
8787        dist_pept_group=dsqrt(dist_pept_group)
8788        dist_side_calf=dsqrt(dist_side_calf)
8789       do j=1,3
8790         pep_side_norm(j)=pep_side(j)/dist_pep_side
8791         side_calf_norm(j)=dist_side_calf
8792       enddo
8793 C now sscale fraction
8794        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8795 C       print *,buff_shield,"buff"
8796 C now sscale
8797         if (sh_frac_dist.le.0.0) cycle
8798 C If we reach here it means that this side chain reaches the shielding sphere
8799 C Lets add him to the list for gradient
8800         ishield_list(i)=ishield_list(i)+1
8801 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8802 C this list is essential otherwise problem would be O3
8803         shield_list(ishield_list(i),i)=k
8804 C Lets have the sscale value
8805         if (sh_frac_dist.gt.1.0) then
8806          scale_fac_dist=1.0d0
8807          do j=1,3
8808          sh_frac_dist_grad(j)=0.0d0
8809          enddo
8810         else
8811          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8812      &                   *(2.0*sh_frac_dist-3.0d0)
8813          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8814      &                  /dist_pep_side/buff_shield*0.5
8815 C remember for the final gradient multiply sh_frac_dist_grad(j)
8816 C for side_chain by factor -2 !
8817          do j=1,3
8818          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8819 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8820 C     &                    sh_frac_dist_grad(j)
8821          enddo
8822         endif
8823 C        if ((i.eq.3).and.(k.eq.2)) then
8824 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8825 C     & ,"TU"
8826 C        endif
8827
8828 C this is what is now we have the distance scaling now volume...
8829       short=short_r_sidechain(itype(k))
8830       long=long_r_sidechain(itype(k))
8831       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8832 C now costhet_grad
8833 C       costhet=0.0d0
8834        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8835 C       costhet_fac=0.0d0
8836        do j=1,3
8837          costhet_grad(j)=costhet_fac*pep_side(j)
8838        enddo
8839 C remember for the final gradient multiply costhet_grad(j)
8840 C for side_chain by factor -2 !
8841 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8842 C pep_side0pept_group is vector multiplication
8843       pep_side0pept_group=0.0
8844       do j=1,3
8845       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8846       enddo
8847       cosalfa=(pep_side0pept_group/
8848      & (dist_pep_side*dist_side_calf))
8849       fac_alfa_sin=1.0-cosalfa**2
8850       fac_alfa_sin=dsqrt(fac_alfa_sin)
8851       rkprim=fac_alfa_sin*(long-short)+short
8852 C now costhet_grad
8853        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8854        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8855
8856        do j=1,3
8857          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8858      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8859      &*(long-short)/fac_alfa_sin*cosalfa/
8860      &((dist_pep_side*dist_side_calf))*
8861      &((side_calf(j))-cosalfa*
8862      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8863
8864         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8865      &*(long-short)/fac_alfa_sin*cosalfa
8866      &/((dist_pep_side*dist_side_calf))*
8867      &(pep_side(j)-
8868      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8869        enddo
8870
8871       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8872      &                    /VSolvSphere_div
8873      &                    *wshield
8874 C now the gradient...
8875 C grad_shield is gradient of Calfa for peptide groups
8876 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8877 C     &               costhet,cosphi
8878 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8879 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8880       do j=1,3
8881       grad_shield(j,i)=grad_shield(j,i)
8882 C gradient po skalowaniu
8883      &                +(sh_frac_dist_grad(j)
8884 C  gradient po costhet
8885      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8886      &-scale_fac_dist*(cosphi_grad_long(j))
8887      &/(1.0-cosphi) )*div77_81
8888      &*VofOverlap
8889 C grad_shield_side is Cbeta sidechain gradient
8890       grad_shield_side(j,ishield_list(i),i)=
8891      &        (sh_frac_dist_grad(j)*-2.0d0
8892      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8893      &       +scale_fac_dist*(cosphi_grad_long(j))
8894      &        *2.0d0/(1.0-cosphi))
8895      &        *div77_81*VofOverlap
8896
8897        grad_shield_loc(j,ishield_list(i),i)=
8898      &   scale_fac_dist*cosphi_grad_loc(j)
8899      &        *2.0d0/(1.0-cosphi)
8900      &        *div77_81*VofOverlap
8901       enddo
8902       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8903       enddo
8904       fac_shield(i)=VolumeTotal*div77_81+div4_81
8905 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8906       enddo
8907       return
8908       end
8909 C--------------------------------------------------------------------------
8910 C-----------------------------------------------------------------------
8911       double precision function sscalelip(r)
8912       double precision r,gamm
8913       include "COMMON.SPLITELE"
8914 C      if(r.lt.r_cut-rlamb) then
8915 C        sscale=1.0d0
8916 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8917 C        gamm=(r-(r_cut-rlamb))/rlamb
8918         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8919 C      else
8920 C        sscale=0d0
8921 C      endif
8922       return
8923       end
8924 C-----------------------------------------------------------------------
8925       double precision function sscagradlip(r)
8926       double precision r,gamm
8927       include "COMMON.SPLITELE"
8928 C     if(r.lt.r_cut-rlamb) then
8929 C        sscagrad=0.0d0
8930 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8931 C        gamm=(r-(r_cut-rlamb))/rlamb
8932         sscagradlip=r*(6*r-6.0d0)
8933 C      else
8934 C        sscagrad=0.0d0
8935 C      endif
8936       return
8937       end
8938
8939 C-----------------------------------------------------------------------
8940 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8941       subroutine Eliptransfer(eliptran)
8942       implicit real*8 (a-h,o-z)
8943       include 'DIMENSIONS'
8944       include 'COMMON.GEO'
8945       include 'COMMON.VAR'
8946       include 'COMMON.LOCAL'
8947       include 'COMMON.CHAIN'
8948       include 'COMMON.DERIV'
8949       include 'COMMON.INTERACT'
8950       include 'COMMON.IOUNITS'
8951       include 'COMMON.CALC'
8952       include 'COMMON.CONTROL'
8953       include 'COMMON.SPLITELE'
8954       include 'COMMON.SBRIDGE'
8955 C this is done by Adasko
8956 C      print *,"wchodze"
8957 C structure of box:
8958 C      water
8959 C--bordliptop-- buffore starts
8960 C--bufliptop--- here true lipid starts
8961 C      lipid
8962 C--buflipbot--- lipid ends buffore starts
8963 C--bordlipbot--buffore ends
8964       eliptran=0.0
8965       write(iout,*) "I am in?"
8966       do i=1,nres
8967 C       do i=1,1
8968         if (itype(i).eq.ntyp1) cycle
8969
8970         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8971         if (positi.le.0) positi=positi+boxzsize
8972 C        print *,i
8973 C first for peptide groups
8974 c for each residue check if it is in lipid or lipid water border area
8975        if ((positi.gt.bordlipbot)
8976      &.and.(positi.lt.bordliptop)) then
8977 C the energy transfer exist
8978         if (positi.lt.buflipbot) then
8979 C what fraction I am in
8980          fracinbuf=1.0d0-
8981      &        ((positi-bordlipbot)/lipbufthick)
8982 C lipbufthick is thickenes of lipid buffore
8983          sslip=sscalelip(fracinbuf)
8984          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8985          eliptran=eliptran+sslip*pepliptran
8986          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8987          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8988 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8989         elseif (positi.gt.bufliptop) then
8990          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8991          sslip=sscalelip(fracinbuf)
8992          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8993          eliptran=eliptran+sslip*pepliptran
8994          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8995          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8996 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8997 C          print *, "doing sscalefor top part"
8998 C         print *,i,sslip,fracinbuf,ssgradlip
8999         else
9000          eliptran=eliptran+pepliptran
9001 C         print *,"I am in true lipid"
9002         endif
9003 C       else
9004 C       eliptran=elpitran+0.0 ! I am in water
9005        endif
9006        enddo
9007 C       print *, "nic nie bylo w lipidzie?"
9008 C now multiply all by the peptide group transfer factor
9009 C       eliptran=eliptran*pepliptran
9010 C now the same for side chains
9011 CV       do i=1,1
9012        do i=1,nres
9013         if (itype(i).eq.ntyp1) cycle
9014         positi=(mod(c(3,i+nres),boxzsize))
9015         if (positi.le.0) positi=positi+boxzsize
9016 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9017 c for each residue check if it is in lipid or lipid water border area
9018 C       respos=mod(c(3,i+nres),boxzsize)
9019 C       print *,positi,bordlipbot,buflipbot
9020        if ((positi.gt.bordlipbot)
9021      & .and.(positi.lt.bordliptop)) then
9022 C the energy transfer exist
9023         if (positi.lt.buflipbot) then
9024          fracinbuf=1.0d0-
9025      &     ((positi-bordlipbot)/lipbufthick)
9026 C lipbufthick is thickenes of lipid buffore
9027          sslip=sscalelip(fracinbuf)
9028          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9029          eliptran=eliptran+sslip*liptranene(itype(i))
9030          gliptranx(3,i)=gliptranx(3,i)
9031      &+ssgradlip*liptranene(itype(i))
9032          gliptranc(3,i-1)= gliptranc(3,i-1)
9033      &+ssgradlip*liptranene(itype(i))
9034 C         print *,"doing sccale for lower part"
9035         elseif (positi.gt.bufliptop) then
9036          fracinbuf=1.0d0-
9037      &((bordliptop-positi)/lipbufthick)
9038          sslip=sscalelip(fracinbuf)
9039          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9040          eliptran=eliptran+sslip*liptranene(itype(i))
9041          gliptranx(3,i)=gliptranx(3,i)
9042      &+ssgradlip*liptranene(itype(i))
9043          gliptranc(3,i-1)= gliptranc(3,i-1)
9044      &+ssgradlip*liptranene(itype(i))
9045 C          print *, "doing sscalefor top part",sslip,fracinbuf
9046         else
9047          eliptran=eliptran+liptranene(itype(i))
9048 C         print *,"I am in true lipid"
9049         endif
9050         endif ! if in lipid or buffor
9051 C       else
9052 C       eliptran=elpitran+0.0 ! I am in water
9053        enddo
9054        return
9055        end
9056 C-------------------------------------------------------------------------------------