source/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 'DIMENSIONS.ZSCOPT'
   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      write(iout,*) 'po elektostatyce'
  50 C
  51 C Calculate electrostatic (H-bonding) energy of the main chain.
  52 C
  53   106 continue
  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            write(iout,*) 'po eelec'
  61
  62 C Calculate excluded-volume interaction energy between peptide groups
  63 C and side chains.
  64 C
  65       call escp(evdw2,evdw2_14)
  66 c
  67 c Calculate the bond-stretching energy
  68 c
  69
  70       call ebond(estr)
  71 C       write (iout,*) "estr",estr
  72 C
  73 C Calculate the disulfide-bridge and other energy and the contributions
  74 C from other distance constraints.
  75 cd    print *,'Calling EHPB'
  76       call edis(ehpb)
  77 cd    print *,'EHPB exitted succesfully.'
  78 C
  79 C Calculate the virtual-bond-angle energy.
  80 C
  81 C      print *,'Bend energy finished.'
  82       call ebend(ebe,ethetacnstr)
  83 cd    print *,'Bend energy finished.'
  84 C
  85 C Calculate the SC local energy.
  86 C
  87       call esc(escloc)
  88 C       print *,'SCLOC energy finished.'
  89 C
  90 C Calculate the virtual-bond torsional energy.
  91 C
  92 cd    print *,'nterm=',nterm
  93       call etor(etors,edihcnstr,fact(1))
  94 C
  95 C 6/23/01 Calculate double-torsional energy
  96 C
  97       call etor_d(etors_d,fact(2))
  98 C
  99 C 21/5/07 Calculate local sicdechain correlation energy
 100 C
 101       call eback_sc_corr(esccor)
 102
 103       if (wliptran.gt.0) then
 104         call Eliptransfer(eliptran)
 105       endif
 106
 107 C
 108 C 12/1/95 Multi-body terms
 109 C
 110       n_corr=0
 111       n_corr1=0
 112       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 113      &    .or. wturn6.gt.0.0d0) then
 114 c         print *,"calling multibody_eello"
 115          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 116 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 117 c         print *,ecorr,ecorr5,ecorr6,eturn6
 118       else
 119          ecorr=0.0d0
 120          ecorr5=0.0d0
 121          ecorr6=0.0d0
 122          eturn6=0.0d0
 123       endif
 124       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 125          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 126       endif
 127 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 128 #ifdef SPLITELE
 129       if (shield_mode.gt.0) then
 130       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 131      & +welec*fact(1)*ees
 132      & +fact(1)*wvdwpp*evdw1
 133      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 134      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 135      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 136      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 137      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 138      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 139      & +wliptran*eliptran
 140       else
 141       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 142      & +wvdwpp*evdw1
 143      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 144      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 145      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 146      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 147      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 148      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 149      & +wliptran*eliptran
 150       endif
 151 #else
 152       if (shield_mode.gt.0) then
 153       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 154      & +welec*fact(1)*(ees+evdw1)
 155      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 156      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 157      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 158      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 159      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 160      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 161      & +wliptran*eliptran
 162       else
 163       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 164      & +welec*fact(1)*(ees+evdw1)
 165      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 166      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 167      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 168      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 169      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 170      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 171      & +wliptran*eliptran
 172       endif
 173 #endif
 174       energia(0)=etot
 175       energia(1)=evdw
 176 #ifdef SCP14
 177       energia(2)=evdw2-evdw2_14
 178       energia(17)=evdw2_14
 179 #else
 180       energia(2)=evdw2
 181       energia(17)=0.0d0
 182 #endif
 183 #ifdef SPLITELE
 184       energia(3)=ees
 185       energia(16)=evdw1
 186 #else
 187       energia(3)=ees+evdw1
 188       energia(16)=0.0d0
 189 #endif
 190       energia(4)=ecorr
 191       energia(5)=ecorr5
 192       energia(6)=ecorr6
 193       energia(7)=eel_loc
 194       energia(8)=eello_turn3
 195       energia(9)=eello_turn4
 196       energia(10)=eturn6
 197       energia(11)=ebe
 198       energia(12)=escloc
 199       energia(13)=etors
 200       energia(14)=etors_d
 201       energia(15)=ehpb
 202       energia(18)=estr
 203       energia(19)=esccor
 204       energia(20)=edihcnstr
 205       energia(21)=evdw_t
 206       energia(24)=ethetacnstr
 207       energia(22)=eliptran
 208 c detecting NaNQ
 209 #ifdef ISNAN
 210 #ifdef AIX
 211       if (isnan(etot).ne.0) energia(0)=1.0d+99
 212 #else
 213       if (isnan(etot)) energia(0)=1.0d+99
 214 #endif
 215 #else
 216       i=0
 217 #ifdef WINPGI
 218       idumm=proc_proc(etot,i)
 219 #else
 220       call proc_proc(etot,i)
 221 #endif
 222       if(i.eq.1)energia(0)=1.0d+99
 223 #endif
 224 #ifdef MPL
 225 c     endif
 226 #endif
 227 #define DEBUG
 228 #ifdef DEBUG
 229       call enerprint(energia,fact)
 230 #endif
 231 #undef DEBUG
 232       if (calc_grad) then
 233 C
 234 C Sum up the components of the Cartesian gradient.
 235 C
 236 #ifdef SPLITELE
 237       do i=1,nct
 238         do j=1,3
 239       if (shield_mode.eq.0) then
 240           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 241      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 242      &                wbond*gradb(j,i)+
 243      &                wstrain*ghpbc(j,i)+
 244      &                wcorr*fact(3)*gradcorr(j,i)+
 245      &                wel_loc*fact(2)*gel_loc(j,i)+
 246      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 247      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 248      &                wcorr5*fact(4)*gradcorr5(j,i)+
 249      &                wcorr6*fact(5)*gradcorr6(j,i)+
 250      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 251      &                wsccor*fact(2)*gsccorc(j,i)
 252      &               +wliptran*gliptranc(j,i)
 253           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 254      &                  wbond*gradbx(j,i)+
 255      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 256      &                  wsccor*fact(2)*gsccorx(j,i)
 257      &                 +wliptran*gliptranx(j,i)
 258         else
 259           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 260      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 261      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 262      &                wbond*gradb(j,i)+
 263      &                wstrain*ghpbc(j,i)+
 264      &                wcorr*fact(3)*gradcorr(j,i)+
 265      &                wel_loc*fact(2)*gel_loc(j,i)+
 266      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 267      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 268      &                wcorr5*fact(4)*gradcorr5(j,i)+
 269      &                wcorr6*fact(5)*gradcorr6(j,i)+
 270      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 271      &                wsccor*fact(2)*gsccorc(j,i)
 272      &               +wliptran*gliptranc(j,i)
 273      &                 +welec*gshieldc(j,i)
 274      &                 +welec*gshieldc_loc(j,i)
 275      &                 +wcorr*gshieldc_ec(j,i)
 276      &                 +wcorr*gshieldc_loc_ec(j,i)
 277      &                 +wturn3*gshieldc_t3(j,i)
 278      &                 +wturn3*gshieldc_loc_t3(j,i)
 279      &                 +wturn4*gshieldc_t4(j,i)
 280      &                 +wturn4*gshieldc_loc_t4(j,i)
 281      &                 +wel_loc*gshieldc_ll(j,i)
 282      &                 +wel_loc*gshieldc_loc_ll(j,i)
 283
 284           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 285      &                 +fact(1)*wscp*gradx_scp(j,i)+
 286      &                  wbond*gradbx(j,i)+
 287      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 288      &                  wsccor*fact(2)*gsccorx(j,i)
 289      &                 +wliptran*gliptranx(j,i)
 290      &                 +welec*gshieldx(j,i)
 291      &                 +wcorr*gshieldx_ec(j,i)
 292      &                 +wturn3*gshieldx_t3(j,i)
 293      &                 +wturn4*gshieldx_t4(j,i)
 294      &                 +wel_loc*gshieldx_ll(j,i)
 295
 296
 297         endif
 298         enddo
 299 #else
 300       do i=1,nct
 301         do j=1,3
 302                 if (shield_mode.eq.0) then
 303           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 304      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 305      &                wbond*gradb(j,i)+
 306      &                wcorr*fact(3)*gradcorr(j,i)+
 307      &                wel_loc*fact(2)*gel_loc(j,i)+
 308      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 309      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 310      &                wcorr5*fact(4)*gradcorr5(j,i)+
 311      &                wcorr6*fact(5)*gradcorr6(j,i)+
 312      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 313      &                wsccor*fact(2)*gsccorc(j,i)
 314      &               +wliptran*gliptranc(j,i)
 315           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 316      &                  wbond*gradbx(j,i)+
 317      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 318      &                  wsccor*fact(1)*gsccorx(j,i)
 319      &                 +wliptran*gliptranx(j,i)
 320               else
 321           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 322      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 323      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 324      &                wbond*gradb(j,i)+
 325      &                wcorr*fact(3)*gradcorr(j,i)+
 326      &                wel_loc*fact(2)*gel_loc(j,i)+
 327      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 328      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 329      &                wcorr5*fact(4)*gradcorr5(j,i)+
 330      &                wcorr6*fact(5)*gradcorr6(j,i)+
 331      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 332      &                wsccor*fact(2)*gsccorc(j,i)
 333      &               +wliptran*gliptranc(j,i)
 334      &                 +welec*gshieldc(j,i)
 335      &                 +welec*gshieldc_loc(j,i)
 336      &                 +wcorr*gshieldc_ec(j,i)
 337      &                 +wcorr*gshieldc_loc_ec(j,i)
 338      &                 +wturn3*gshieldc_t3(j,i)
 339      &                 +wturn3*gshieldc_loc_t3(j,i)
 340      &                 +wturn4*gshieldc_t4(j,i)
 341      &                 +wturn4*gshieldc_loc_t4(j,i)
 342      &                 +wel_loc*gshieldc_ll(j,i)
 343      &                 +wel_loc*gshieldc_loc_ll(j,i)
 344
 345           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 346      &                  fact(1)*wscp*gradx_scp(j,i)+
 347      &                  wbond*gradbx(j,i)+
 348      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 349      &                  wsccor*fact(1)*gsccorx(j,i)
 350      &                 +wliptran*gliptranx(j,i)
 351      &                 +welec*gshieldx(j,i)
 352      &                 +wcorr*gshieldx_ec(j,i)
 353      &                 +wturn3*gshieldx_t3(j,i)
 354      &                 +wturn4*gshieldx_t4(j,i)
 355      &                 +wel_loc*gshieldx_ll(j,i)
 356
 357          endif
 358         enddo
 359 #endif
 360       enddo
 361
 362
 363       do i=1,nres-3
 364         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 365      &   +wcorr5*fact(4)*g_corr5_loc(i)
 366      &   +wcorr6*fact(5)*g_corr6_loc(i)
 367      &   +wturn4*fact(3)*gel_loc_turn4(i)
 368      &   +wturn3*fact(2)*gel_loc_turn3(i)
 369      &   +wturn6*fact(5)*gel_loc_turn6(i)
 370      &   +wel_loc*fact(2)*gel_loc_loc(i)
 371 c     &   +wsccor*fact(1)*gsccor_loc(i)
 372 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 373       enddo
 374       endif
 375       if (dyn_ss) call dyn_set_nss
 376       return
 377       end
 378 C------------------------------------------------------------------------
 379       subroutine enerprint(energia,fact)
 380       implicit real*8 (a-h,o-z)
 381       include 'DIMENSIONS'
 382       include 'DIMENSIONS.ZSCOPT'
 383       include 'COMMON.IOUNITS'
 384       include 'COMMON.FFIELD'
 385       include 'COMMON.SBRIDGE'
 386       double precision energia(0:max_ene),fact(6)
 387       etot=energia(0)
 388       evdw=energia(1)+fact(6)*energia(21)
 389 #ifdef SCP14
 390       evdw2=energia(2)+energia(17)
 391 #else
 392       evdw2=energia(2)
 393 #endif
 394       ees=energia(3)
 395 #ifdef SPLITELE
 396       evdw1=energia(16)
 397 #endif
 398       ecorr=energia(4)
 399       ecorr5=energia(5)
 400       ecorr6=energia(6)
 401       eel_loc=energia(7)
 402       eello_turn3=energia(8)
 403       eello_turn4=energia(9)
 404       eello_turn6=energia(10)
 405       ebe=energia(11)
 406       escloc=energia(12)
 407       etors=energia(13)
 408       etors_d=energia(14)
 409       ehpb=energia(15)
 410       esccor=energia(19)
 411       edihcnstr=energia(20)
 412       estr=energia(18)
 413       ethetacnstr=energia(24)
 414       eliptran=energia(22)
 415 #ifdef SPLITELE
 416       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 417      &  wvdwpp,
 418      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 419      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 420      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 421      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 422      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 423      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 424      & eliptran,wliptran,etot
 425    10 format (/'Virtual-chain energies:'//
 426      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 427      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 428      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 429      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 430      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 431      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 432      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 433      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 434      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 435      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 436      & ' (SS bridges & dist. cnstr.)'/
 437      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 438      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 439      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 440      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 441      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 442      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 443      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 444      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 445      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 446      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 447      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 448      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 449      & 'ETOT=  ',1pE16.6,' (total)')
 450 #else
 451       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 452      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 453      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 454      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 455      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 456      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 457      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 458    10 format (/'Virtual-chain energies:'//
 459      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 460      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 461      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 462      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 463      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 464      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 465      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 466      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 467      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 468      & ' (SS bridges & dist. cnstr.)'/
 469      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 470      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 471      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 472      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 473      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 474      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 475      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 476      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 477      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 478      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 479      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 480      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 481      & 'ETOT=  ',1pE16.6,' (total)')
 482 #endif
 483       return
 484       end
 485 C-----------------------------------------------------------------------
 486       subroutine elj(evdw,evdw_t)
 487 C
 488 C This subroutine calculates the interaction energy of nonbonded side chains
 489 C assuming the LJ potential of interaction.
 490 C
 491       implicit real*8 (a-h,o-z)
 492       include 'DIMENSIONS'
 493       include 'DIMENSIONS.ZSCOPT'
 494       include "DIMENSIONS.COMPAR"
 495       parameter (accur=1.0d-10)
 496       include 'COMMON.GEO'
 497       include 'COMMON.VAR'
 498       include 'COMMON.LOCAL'
 499       include 'COMMON.CHAIN'
 500       include 'COMMON.DERIV'
 501       include 'COMMON.INTERACT'
 502       include 'COMMON.TORSION'
 503       include 'COMMON.ENEPS'
 504       include 'COMMON.SBRIDGE'
 505       include 'COMMON.NAMES'
 506       include 'COMMON.IOUNITS'
 507       include 'COMMON.CONTACTS'
 508       dimension gg(3)
 509       integer icant
 510       external icant
 511 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 512 c ROZNICA z cluster
 513       do i=1,210
 514         do j=1,2
 515           eneps_temp(j,i)=0.0d0
 516         enddo
 517       enddo
 518 cROZNICA
 519
 520       evdw=0.0D0
 521       evdw_t=0.0d0
 522       do i=iatsc_s,iatsc_e
 523         itypi=iabs(itype(i))
 524         if (itypi.eq.ntyp1) cycle
 525         itypi1=iabs(itype(i+1))
 526         xi=c(1,nres+i)
 527         yi=c(2,nres+i)
 528         zi=c(3,nres+i)
 529 C Change 12/1/95
 530         num_conti=0
 531 C
 532 C Calculate SC interaction energy.
 533 C
 534         do iint=1,nint_gr(i)
 535 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 536 cd   &                  'iend=',iend(i,iint)
 537           do j=istart(i,iint),iend(i,iint)
 538             itypj=iabs(itype(j))
 539             if (itypj.eq.ntyp1) cycle
 540             xj=c(1,nres+j)-xi
 541             yj=c(2,nres+j)-yi
 542             zj=c(3,nres+j)-zi
 543 C Change 12/1/95 to calculate four-body interactions
 544             rij=xj*xj+yj*yj+zj*zj
 545             rrij=1.0D0/rij
 546 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 547             eps0ij=eps(itypi,itypj)
 548             fac=rrij**expon2
 549             e1=fac*fac*aa
 550             e2=fac*bb
 551             evdwij=e1+e2
 552             ij=icant(itypi,itypj)
 553 c ROZNICA z cluster
 554             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 555             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 556 c
 557
 558 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 559 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 560 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 561 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 562 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 563 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 564             if (bb.gt.0.0d0) then
 565               evdw=evdw+evdwij
 566             else
 567               evdw_t=evdw_t+evdwij
 568             endif
 569             if (calc_grad) then
 570 C
 571 C Calculate the components of the gradient in DC and X
 572 C
 573             fac=-rrij*(e1+evdwij)
 574             gg(1)=xj*fac
 575             gg(2)=yj*fac
 576             gg(3)=zj*fac
 577             do k=1,3
 578               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 579               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 580             enddo
 581             do k=i,j-1
 582               do l=1,3
 583                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 584               enddo
 585             enddo
 586             endif
 587 C
 588 C 12/1/95, revised on 5/20/97
 589 C
 590 C Calculate the contact function. The ith column of the array JCONT will
 591 C contain the numbers of atoms that make contacts with the atom I (of numbers
 592 C greater than I). The arrays FACONT and GACONT will contain the values of
 593 C the contact function and its derivative.
 594 C
 595 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 596 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 597 C Uncomment next line, if the correlation interactions are contact function only
 598             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 599               rij=dsqrt(rij)
 600               sigij=sigma(itypi,itypj)
 601               r0ij=rs0(itypi,itypj)
 602 C
 603 C Check whether the SC's are not too far to make a contact.
 604 C
 605               rcut=1.5d0*r0ij
 606               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 607 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 608 C
 609               if (fcont.gt.0.0D0) then
 610 C If the SC-SC distance if close to sigma, apply spline.
 611 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 612 cAdam &             fcont1,fprimcont1)
 613 cAdam           fcont1=1.0d0-fcont1
 614 cAdam           if (fcont1.gt.0.0d0) then
 615 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 616 cAdam             fcont=fcont*fcont1
 617 cAdam           endif
 618 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 619 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 620 cga             do k=1,3
 621 cga               gg(k)=gg(k)*eps0ij
 622 cga             enddo
 623 cga             eps0ij=-evdwij*eps0ij
 624 C Uncomment for AL's type of SC correlation interactions.
 625 cadam           eps0ij=-evdwij
 626                 num_conti=num_conti+1
 627                 jcont(num_conti,i)=j
 628                 facont(num_conti,i)=fcont*eps0ij
 629                 fprimcont=eps0ij*fprimcont/rij
 630                 fcont=expon*fcont
 631 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 632 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 633 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 634 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 635                 gacont(1,num_conti,i)=-fprimcont*xj
 636                 gacont(2,num_conti,i)=-fprimcont*yj
 637                 gacont(3,num_conti,i)=-fprimcont*zj
 638 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 639 cd              write (iout,'(2i3,3f10.5)')
 640 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 641               endif
 642             endif
 643           enddo      ! j
 644         enddo        ! iint
 645 C Change 12/1/95
 646         num_cont(i)=num_conti
 647       enddo          ! i
 648       if (calc_grad) then
 649       do i=1,nct
 650         do j=1,3
 651           gvdwc(j,i)=expon*gvdwc(j,i)
 652           gvdwx(j,i)=expon*gvdwx(j,i)
 653         enddo
 654       enddo
 655       endif
 656 C******************************************************************************
 657 C
 658 C                              N O T E !!!
 659 C
 660 C To save time, the factor of EXPON has been extracted from ALL components
 661 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 662 C use!
 663 C
 664 C******************************************************************************
 665       return
 666       end
 667 C-----------------------------------------------------------------------------
 668       subroutine eljk(evdw,evdw_t)
 669 C
 670 C This subroutine calculates the interaction energy of nonbonded side chains
 671 C assuming the LJK potential of interaction.
 672 C
 673       implicit real*8 (a-h,o-z)
 674       include 'DIMENSIONS'
 675       include 'DIMENSIONS.ZSCOPT'
 676       include "DIMENSIONS.COMPAR"
 677       include 'COMMON.GEO'
 678       include 'COMMON.VAR'
 679       include 'COMMON.LOCAL'
 680       include 'COMMON.CHAIN'
 681       include 'COMMON.DERIV'
 682       include 'COMMON.INTERACT'
 683       include 'COMMON.ENEPS'
 684       include 'COMMON.IOUNITS'
 685       include 'COMMON.NAMES'
 686       dimension gg(3)
 687       logical scheck
 688       integer icant
 689       external icant
 690 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 691       do i=1,210
 692         do j=1,2
 693           eneps_temp(j,i)=0.0d0
 694         enddo
 695       enddo
 696       evdw=0.0D0
 697       evdw_t=0.0d0
 698       do i=iatsc_s,iatsc_e
 699         itypi=iabs(itype(i))
 700         if (itypi.eq.ntyp1) cycle
 701         itypi1=iabs(itype(i+1))
 702         xi=c(1,nres+i)
 703         yi=c(2,nres+i)
 704         zi=c(3,nres+i)
 705 C
 706 C Calculate SC interaction energy.
 707 C
 708         do iint=1,nint_gr(i)
 709           do j=istart(i,iint),iend(i,iint)
 710             itypj=iabs(itype(j))
 711             if (itypj.eq.ntyp1) cycle
 712             xj=c(1,nres+j)-xi
 713             yj=c(2,nres+j)-yi
 714             zj=c(3,nres+j)-zi
 715             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 716             fac_augm=rrij**expon
 717             e_augm=augm(itypi,itypj)*fac_augm
 718             r_inv_ij=dsqrt(rrij)
 719             rij=1.0D0/r_inv_ij
 720             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 721             fac=r_shift_inv**expon
 722             e1=fac*fac*aa
 723             e2=fac*bb
 724             evdwij=e_augm+e1+e2
 725             ij=icant(itypi,itypj)
 726             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 727      &        /dabs(eps(itypi,itypj))
 728             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 729 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 730 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 731 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 732 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 733 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 734 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 735 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 736             if (bb.gt.0.0d0) then
 737               evdw=evdw+evdwij
 738             else
 739               evdw_t=evdw_t+evdwij
 740             endif
 741             if (calc_grad) then
 742 C
 743 C Calculate the components of the gradient in DC and X
 744 C
 745             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 746             gg(1)=xj*fac
 747             gg(2)=yj*fac
 748             gg(3)=zj*fac
 749             do k=1,3
 750               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 751               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 752             enddo
 753             do k=i,j-1
 754               do l=1,3
 755                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 756               enddo
 757             enddo
 758             endif
 759           enddo      ! j
 760         enddo        ! iint
 761       enddo          ! i
 762       if (calc_grad) then
 763       do i=1,nct
 764         do j=1,3
 765           gvdwc(j,i)=expon*gvdwc(j,i)
 766           gvdwx(j,i)=expon*gvdwx(j,i)
 767         enddo
 768       enddo
 769       endif
 770       return
 771       end
 772 C-----------------------------------------------------------------------------
 773       subroutine ebp(evdw,evdw_t)
 774 C
 775 C This subroutine calculates the interaction energy of nonbonded side chains
 776 C assuming the Berne-Pechukas potential of interaction.
 777 C
 778       implicit real*8 (a-h,o-z)
 779       include 'DIMENSIONS'
 780       include 'DIMENSIONS.ZSCOPT'
 781       include "DIMENSIONS.COMPAR"
 782       include 'COMMON.GEO'
 783       include 'COMMON.VAR'
 784       include 'COMMON.LOCAL'
 785       include 'COMMON.CHAIN'
 786       include 'COMMON.DERIV'
 787       include 'COMMON.NAMES'
 788       include 'COMMON.INTERACT'
 789       include 'COMMON.ENEPS'
 790       include 'COMMON.IOUNITS'
 791       include 'COMMON.CALC'
 792       common /srutu/ icall
 793 c     double precision rrsave(maxdim)
 794       logical lprn
 795       integer icant
 796       external icant
 797       do i=1,210
 798         do j=1,2
 799           eneps_temp(j,i)=0.0d0
 800         enddo
 801       enddo
 802       evdw=0.0D0
 803       evdw_t=0.0d0
 804 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 805 c     if (icall.eq.0) then
 806 c       lprn=.true.
 807 c     else
 808         lprn=.false.
 809 c     endif
 810       ind=0
 811       do i=iatsc_s,iatsc_e
 812         itypi=iabs(itype(i))
 813         if (itypi.eq.ntyp1) cycle
 814         itypi1=iabs(itype(i+1))
 815         xi=c(1,nres+i)
 816         yi=c(2,nres+i)
 817         zi=c(3,nres+i)
 818         dxi=dc_norm(1,nres+i)
 819         dyi=dc_norm(2,nres+i)
 820         dzi=dc_norm(3,nres+i)
 821         dsci_inv=vbld_inv(i+nres)
 822 C
 823 C Calculate SC interaction energy.
 824 C
 825         do iint=1,nint_gr(i)
 826           do j=istart(i,iint),iend(i,iint)
 827             ind=ind+1
 828             itypj=iabs(itype(j))
 829             if (itypj.eq.ntyp1) cycle
 830             dscj_inv=vbld_inv(j+nres)
 831             chi1=chi(itypi,itypj)
 832             chi2=chi(itypj,itypi)
 833             chi12=chi1*chi2
 834             chip1=chip(itypi)
 835             chip2=chip(itypj)
 836             chip12=chip1*chip2
 837             alf1=alp(itypi)
 838             alf2=alp(itypj)
 839             alf12=0.5D0*(alf1+alf2)
 840 C For diagnostics only!!!
 841 c           chi1=0.0D0
 842 c           chi2=0.0D0
 843 c           chi12=0.0D0
 844 c           chip1=0.0D0
 845 c           chip2=0.0D0
 846 c           chip12=0.0D0
 847 c           alf1=0.0D0
 848 c           alf2=0.0D0
 849 c           alf12=0.0D0
 850             xj=c(1,nres+j)-xi
 851             yj=c(2,nres+j)-yi
 852             zj=c(3,nres+j)-zi
 853             dxj=dc_norm(1,nres+j)
 854             dyj=dc_norm(2,nres+j)
 855             dzj=dc_norm(3,nres+j)
 856             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 857 cd          if (icall.eq.0) then
 858 cd            rrsave(ind)=rrij
 859 cd          else
 860 cd            rrij=rrsave(ind)
 861 cd          endif
 862             rij=dsqrt(rrij)
 863 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 864             call sc_angular
 865 C Calculate whole angle-dependent part of epsilon and contributions
 866 C to its derivatives
 867             fac=(rrij*sigsq)**expon2
 868             e1=fac*fac*aa
 869             e2=fac*bb
 870             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 871             eps2der=evdwij*eps3rt
 872             eps3der=evdwij*eps2rt
 873             evdwij=evdwij*eps2rt*eps3rt
 874             ij=icant(itypi,itypj)
 875             aux=eps1*eps2rt**2*eps3rt**2
 876             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 877      &        /dabs(eps(itypi,itypj))
 878             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 879             if (bb.gt.0.0d0) then
 880               evdw=evdw+evdwij
 881             else
 882               evdw_t=evdw_t+evdwij
 883             endif
 884             if (calc_grad) then
 885             if (lprn) then
 886             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 887             epsi=bb**2/aa
 888             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 889      &        restyp(itypi),i,restyp(itypj),j,
 890      &        epsi,sigm,chi1,chi2,chip1,chip2,
 891      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 892      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 893      &        evdwij
 894             endif
 895 C Calculate gradient components.
 896             e1=e1*eps1*eps2rt**2*eps3rt**2
 897             fac=-expon*(e1+evdwij)
 898             sigder=fac/sigsq
 899             fac=rrij*fac
 900 C Calculate radial part of the gradient
 901             gg(1)=xj*fac
 902             gg(2)=yj*fac
 903             gg(3)=zj*fac
 904 C Calculate the angular part of the gradient and sum add the contributions
 905 C to the appropriate components of the Cartesian gradient.
 906             call sc_grad
 907             endif
 908           enddo      ! j
 909         enddo        ! iint
 910       enddo          ! i
 911 c     stop
 912       return
 913       end
 914 C-----------------------------------------------------------------------------
 915       subroutine egb(evdw,evdw_t)
 916 C
 917 C This subroutine calculates the interaction energy of nonbonded side chains
 918 C assuming the Gay-Berne potential of interaction.
 919 C
 920       implicit real*8 (a-h,o-z)
 921       include 'DIMENSIONS'
 922       include 'DIMENSIONS.ZSCOPT'
 923       include "DIMENSIONS.COMPAR"
 924       include 'COMMON.GEO'
 925       include 'COMMON.VAR'
 926       include 'COMMON.LOCAL'
 927       include 'COMMON.CHAIN'
 928       include 'COMMON.DERIV'
 929       include 'COMMON.NAMES'
 930       include 'COMMON.INTERACT'
 931       include 'COMMON.ENEPS'
 932       include 'COMMON.IOUNITS'
 933       include 'COMMON.CALC'
 934       include 'COMMON.SBRIDGE'
 935       logical lprn
 936       common /srutu/icall
 937       integer icant,xshift,yshift,zshift
 938       external icant
 939       do i=1,210
 940         do j=1,2
 941           eneps_temp(j,i)=0.0d0
 942         enddo
 943       enddo
 944 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 945       evdw=0.0D0
 946       evdw_t=0.0d0
 947       lprn=.false.
 948 c      if (icall.gt.0) lprn=.true.
 949       ind=0
 950       do i=iatsc_s,iatsc_e
 951         itypi=iabs(itype(i))
 952         if (itypi.eq.ntyp1) cycle
 953         itypi1=iabs(itype(i+1))
 954         xi=c(1,nres+i)
 955         yi=c(2,nres+i)
 956         zi=c(3,nres+i)
 957 C returning the ith atom to box
 958           xi=mod(xi,boxxsize)
 959           if (xi.lt.0) xi=xi+boxxsize
 960           yi=mod(yi,boxysize)
 961           if (yi.lt.0) yi=yi+boxysize
 962           zi=mod(zi,boxzsize)
 963           if (zi.lt.0) zi=zi+boxzsize
 964        if ((zi.gt.bordlipbot)
 965      &.and.(zi.lt.bordliptop)) then
 966 C the energy transfer exist
 967         if (zi.lt.buflipbot) then
 968 C what fraction I am in
 969          fracinbuf=1.0d0-
 970      &        ((zi-bordlipbot)/lipbufthick)
 971 C lipbufthick is thickenes of lipid buffore
 972          sslipi=sscalelip(fracinbuf)
 973          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 974         elseif (zi.gt.bufliptop) then
 975          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 976          sslipi=sscalelip(fracinbuf)
 977          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 978         else
 979          sslipi=1.0d0
 980          ssgradlipi=0.0
 981         endif
 982        else
 983          sslipi=0.0d0
 984          ssgradlipi=0.0
 985        endif
 986
 987         dxi=dc_norm(1,nres+i)
 988         dyi=dc_norm(2,nres+i)
 989         dzi=dc_norm(3,nres+i)
 990         dsci_inv=vbld_inv(i+nres)
 991 C
 992 C Calculate SC interaction energy.
 993 C
 994         do iint=1,nint_gr(i)
 995           do j=istart(i,iint),iend(i,iint)
 996             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 997               call dyn_ssbond_ene(i,j,evdwij)
 998               evdw=evdw+evdwij
 999 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1000 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1001 C triple bond artifac removal
1002              do k=j+1,iend(i,iint)
1003 C search over all next residues
1004               if (dyn_ss_mask(k)) then
1005 C check if they are cysteins
1006 C              write(iout,*) 'k=',k
1007               call triple_ssbond_ene(i,j,k,evdwij)
1008 C call the energy function that removes the artifical triple disulfide
1009 C bond the soubroutine is located in ssMD.F
1010               evdw=evdw+evdwij
1011 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1012 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1013               endif!dyn_ss_mask(k)
1014              enddo! k
1015             ELSE
1016             ind=ind+1
1017             itypj=iabs(itype(j))
1018             if (itypj.eq.ntyp1) cycle
1019             dscj_inv=vbld_inv(j+nres)
1020             sig0ij=sigma(itypi,itypj)
1021             chi1=chi(itypi,itypj)
1022             chi2=chi(itypj,itypi)
1023             chi12=chi1*chi2
1024             chip1=chip(itypi)
1025             chip2=chip(itypj)
1026             chip12=chip1*chip2
1027             alf1=alp(itypi)
1028             alf2=alp(itypj)
1029             alf12=0.5D0*(alf1+alf2)
1030 C For diagnostics only!!!
1031 c           chi1=0.0D0
1032 c           chi2=0.0D0
1033 c           chi12=0.0D0
1034 c           chip1=0.0D0
1035 c           chip2=0.0D0
1036 c           chip12=0.0D0
1037 c           alf1=0.0D0
1038 c           alf2=0.0D0
1039 c           alf12=0.0D0
1040             xj=c(1,nres+j)
1041             yj=c(2,nres+j)
1042             zj=c(3,nres+j)
1043 C returning jth atom to box
1044           xj=mod(xj,boxxsize)
1045           if (xj.lt.0) xj=xj+boxxsize
1046           yj=mod(yj,boxysize)
1047           if (yj.lt.0) yj=yj+boxysize
1048           zj=mod(zj,boxzsize)
1049           if (zj.lt.0) zj=zj+boxzsize
1050        if ((zj.gt.bordlipbot)
1051      &.and.(zj.lt.bordliptop)) then
1052 C the energy transfer exist
1053         if (zj.lt.buflipbot) then
1054 C what fraction I am in
1055          fracinbuf=1.0d0-
1056      &        ((zj-bordlipbot)/lipbufthick)
1057 C lipbufthick is thickenes of lipid buffore
1058          sslipj=sscalelip(fracinbuf)
1059          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1060         elseif (zj.gt.bufliptop) then
1061          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1062          sslipj=sscalelip(fracinbuf)
1063          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1064         else
1065          sslipj=1.0d0
1066          ssgradlipj=0.0
1067         endif
1068        else
1069          sslipj=0.0d0
1070          ssgradlipj=0.0
1071        endif
1072       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1073      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1074       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1075      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1076 C       if (aa.ne.aa_aq(itypi,itypj)) then
1077
1078       write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1079      & bb_aq(itypi,itypj)-bb,
1080      & sslipi,sslipj
1081 C         endif
1082
1083 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1084 C checking the distance
1085       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1086       xj_safe=xj
1087       yj_safe=yj
1088       zj_safe=zj
1089       subchap=0
1090 C finding the closest
1091       do xshift=-1,1
1092       do yshift=-1,1
1093       do zshift=-1,1
1094           xj=xj_safe+xshift*boxxsize
1095           yj=yj_safe+yshift*boxysize
1096           zj=zj_safe+zshift*boxzsize
1097           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1098           if(dist_temp.lt.dist_init) then
1099             dist_init=dist_temp
1100             xj_temp=xj
1101             yj_temp=yj
1102             zj_temp=zj
1103             subchap=1
1104           endif
1105        enddo
1106        enddo
1107        enddo
1108        if (subchap.eq.1) then
1109           xj=xj_temp-xi
1110           yj=yj_temp-yi
1111           zj=zj_temp-zi
1112        else
1113           xj=xj_safe-xi
1114           yj=yj_safe-yi
1115           zj=zj_safe-zi
1116        endif
1117
1118             dxj=dc_norm(1,nres+j)
1119             dyj=dc_norm(2,nres+j)
1120             dzj=dc_norm(3,nres+j)
1121 c            write (iout,*) i,j,xj,yj,zj
1122             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1123             rij=dsqrt(rrij)
1124             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1125             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1126             if (sss.le.0.0) cycle
1127 C Calculate angle-dependent terms of energy and contributions to their
1128 C derivatives.
1129
1130             call sc_angular
1131             sigsq=1.0D0/sigsq
1132             sig=sig0ij*dsqrt(sigsq)
1133             rij_shift=1.0D0/rij-sig+sig0ij
1134 C I hate to put IF's in the loops, but here don't have another choice!!!!
1135             if (rij_shift.le.0.0D0) then
1136               evdw=1.0D20
1137               return
1138             endif
1139             sigder=-sig*sigsq
1140 c---------------------------------------------------------------
1141             rij_shift=1.0D0/rij_shift
1142             fac=rij_shift**expon
1143             e1=fac*fac*aa
1144             e2=fac*bb
1145             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1146             eps2der=evdwij*eps3rt
1147             eps3der=evdwij*eps2rt
1148             evdwij=evdwij*eps2rt*eps3rt
1149             if (bb.gt.0) then
1150               evdw=evdw+evdwij*sss
1151             else
1152               evdw_t=evdw_t+evdwij*sss
1153             endif
1154             ij=icant(itypi,itypj)
1155             aux=eps1*eps2rt**2*eps3rt**2
1156             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1157      &        /dabs(eps(itypi,itypj))
1158             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1159 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1160 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1161 c     &         aux*e2/eps(itypi,itypj)
1162 c            if (lprn) then
1163             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1164             epsi=bb**2/aa
1165 #define DEBUG
1166 #ifdef DEBUG
1167             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1168      &        restyp(itypi),i,restyp(itypj),j,
1169      &        epsi,sigm,chi1,chi2,chip1,chip2,
1170      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1171      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1172      &        evdwij
1173              write (iout,*) "partial sum", evdw, evdw_t
1174 #endif
1175 #undef DEBUG
1176 c            endif
1177             if (calc_grad) then
1178 C Calculate gradient components.
1179             e1=e1*eps1*eps2rt**2*eps3rt**2
1180             fac=-expon*(e1+evdwij)*rij_shift
1181             sigder=fac*sigder
1182             fac=rij*fac
1183             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1184 C Calculate the radial part of the gradient
1185             gg(1)=xj*fac
1186             gg(2)=yj*fac
1187             gg(3)=zj*fac
1188 C Calculate angular part of the gradient.
1189             call sc_grad
1190             endif
1191 C            write(iout,*)  "partial sum", evdw, evdw_t
1192             ENDIF    ! dyn_ss
1193           enddo      ! j
1194         enddo        ! iint
1195       enddo          ! i
1196       return
1197       end
1198 C-----------------------------------------------------------------------------
1199       subroutine egbv(evdw,evdw_t)
1200 C
1201 C This subroutine calculates the interaction energy of nonbonded side chains
1202 C assuming the Gay-Berne-Vorobjev potential of interaction.
1203 C
1204       implicit real*8 (a-h,o-z)
1205       include 'DIMENSIONS'
1206       include 'DIMENSIONS.ZSCOPT'
1207       include "DIMENSIONS.COMPAR"
1208       include 'COMMON.GEO'
1209       include 'COMMON.VAR'
1210       include 'COMMON.LOCAL'
1211       include 'COMMON.CHAIN'
1212       include 'COMMON.DERIV'
1213       include 'COMMON.NAMES'
1214       include 'COMMON.INTERACT'
1215       include 'COMMON.ENEPS'
1216       include 'COMMON.IOUNITS'
1217       include 'COMMON.CALC'
1218       common /srutu/ icall
1219       logical lprn
1220       integer icant
1221       external icant
1222       do i=1,210
1223         do j=1,2
1224           eneps_temp(j,i)=0.0d0
1225         enddo
1226       enddo
1227       evdw=0.0D0
1228       evdw_t=0.0d0
1229 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1230       evdw=0.0D0
1231       lprn=.false.
1232 c      if (icall.gt.0) lprn=.true.
1233       ind=0
1234       do i=iatsc_s,iatsc_e
1235         itypi=iabs(itype(i))
1236         if (itypi.eq.ntyp1) cycle
1237         itypi1=iabs(itype(i+1))
1238         xi=c(1,nres+i)
1239         yi=c(2,nres+i)
1240         zi=c(3,nres+i)
1241         dxi=dc_norm(1,nres+i)
1242         dyi=dc_norm(2,nres+i)
1243         dzi=dc_norm(3,nres+i)
1244         dsci_inv=vbld_inv(i+nres)
1245 C
1246 C Calculate SC interaction energy.
1247 C
1248         do iint=1,nint_gr(i)
1249           do j=istart(i,iint),iend(i,iint)
1250             ind=ind+1
1251             itypj=iabs(itype(j))
1252             if (itypj.eq.ntyp1) cycle
1253             dscj_inv=vbld_inv(j+nres)
1254             sig0ij=sigma(itypi,itypj)
1255             r0ij=r0(itypi,itypj)
1256             chi1=chi(itypi,itypj)
1257             chi2=chi(itypj,itypi)
1258             chi12=chi1*chi2
1259             chip1=chip(itypi)
1260             chip2=chip(itypj)
1261             chip12=chip1*chip2
1262             alf1=alp(itypi)
1263             alf2=alp(itypj)
1264             alf12=0.5D0*(alf1+alf2)
1265 C For diagnostics only!!!
1266 c           chi1=0.0D0
1267 c           chi2=0.0D0
1268 c           chi12=0.0D0
1269 c           chip1=0.0D0
1270 c           chip2=0.0D0
1271 c           chip12=0.0D0
1272 c           alf1=0.0D0
1273 c           alf2=0.0D0
1274 c           alf12=0.0D0
1275             xj=c(1,nres+j)-xi
1276             yj=c(2,nres+j)-yi
1277             zj=c(3,nres+j)-zi
1278             dxj=dc_norm(1,nres+j)
1279             dyj=dc_norm(2,nres+j)
1280             dzj=dc_norm(3,nres+j)
1281             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1282             rij=dsqrt(rrij)
1283 C Calculate angle-dependent terms of energy and contributions to their
1284 C derivatives.
1285             call sc_angular
1286             sigsq=1.0D0/sigsq
1287             sig=sig0ij*dsqrt(sigsq)
1288             rij_shift=1.0D0/rij-sig+r0ij
1289 C I hate to put IF's in the loops, but here don't have another choice!!!!
1290             if (rij_shift.le.0.0D0) then
1291               evdw=1.0D20
1292               return
1293             endif
1294             sigder=-sig*sigsq
1295 c---------------------------------------------------------------
1296             rij_shift=1.0D0/rij_shift
1297             fac=rij_shift**expon
1298             e1=fac*fac*aa
1299             e2=fac*bb
1300             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1301             eps2der=evdwij*eps3rt
1302             eps3der=evdwij*eps2rt
1303             fac_augm=rrij**expon
1304             e_augm=augm(itypi,itypj)*fac_augm
1305             evdwij=evdwij*eps2rt*eps3rt
1306             if (bb.gt.0.0d0) then
1307               evdw=evdw+evdwij+e_augm
1308             else
1309               evdw_t=evdw_t+evdwij+e_augm
1310             endif
1311             ij=icant(itypi,itypj)
1312             aux=eps1*eps2rt**2*eps3rt**2
1313             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1314      &        /dabs(eps(itypi,itypj))
1315             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1316 c            eneps_temp(ij)=eneps_temp(ij)
1317 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1318 c            if (lprn) then
1319 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1320 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1321 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1322 c     &        restyp(itypi),i,restyp(itypj),j,
1323 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1324 c     &        chi1,chi2,chip1,chip2,
1325 c     &        eps1,eps2rt**2,eps3rt**2,
1326 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1327 c     &        evdwij+e_augm
1328 c            endif
1329             if (calc_grad) then
1330 C Calculate gradient components.
1331             e1=e1*eps1*eps2rt**2*eps3rt**2
1332             fac=-expon*(e1+evdwij)*rij_shift
1333             sigder=fac*sigder
1334             fac=rij*fac-2*expon*rrij*e_augm
1335 C Calculate the radial part of the gradient
1336             gg(1)=xj*fac
1337             gg(2)=yj*fac
1338             gg(3)=zj*fac
1339 C Calculate angular part of the gradient.
1340             call sc_grad
1341             endif
1342           enddo      ! j
1343         enddo        ! iint
1344       enddo          ! i
1345       return
1346       end
1347 C-----------------------------------------------------------------------------
1348       subroutine sc_angular
1349 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1350 C om12. Called by ebp, egb, and egbv.
1351       implicit none
1352       include 'COMMON.CALC'
1353       erij(1)=xj*rij
1354       erij(2)=yj*rij
1355       erij(3)=zj*rij
1356       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1357       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1358       om12=dxi*dxj+dyi*dyj+dzi*dzj
1359       chiom12=chi12*om12
1360 C Calculate eps1(om12) and its derivative in om12
1361       faceps1=1.0D0-om12*chiom12
1362       faceps1_inv=1.0D0/faceps1
1363       eps1=dsqrt(faceps1_inv)
1364 C Following variable is eps1*deps1/dom12
1365       eps1_om12=faceps1_inv*chiom12
1366 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1367 C and om12.
1368       om1om2=om1*om2
1369       chiom1=chi1*om1
1370       chiom2=chi2*om2
1371       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1372       sigsq=1.0D0-facsig*faceps1_inv
1373       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1374       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1375       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1376 C Calculate eps2 and its derivatives in om1, om2, and om12.
1377       chipom1=chip1*om1
1378       chipom2=chip2*om2
1379       chipom12=chip12*om12
1380       facp=1.0D0-om12*chipom12
1381       facp_inv=1.0D0/facp
1382       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1383 C Following variable is the square root of eps2
1384       eps2rt=1.0D0-facp1*facp_inv
1385 C Following three variables are the derivatives of the square root of eps
1386 C in om1, om2, and om12.
1387       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1388       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1389       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1390 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1391       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1392 C Calculate whole angle-dependent part of epsilon and contributions
1393 C to its derivatives
1394       return
1395       end
1396 C----------------------------------------------------------------------------
1397       subroutine sc_grad
1398       implicit real*8 (a-h,o-z)
1399       include 'DIMENSIONS'
1400       include 'DIMENSIONS.ZSCOPT'
1401       include 'COMMON.CHAIN'
1402       include 'COMMON.DERIV'
1403       include 'COMMON.CALC'
1404       double precision dcosom1(3),dcosom2(3)
1405       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1406       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1407       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1408      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1409       do k=1,3
1410         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1411         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1412       enddo
1413       do k=1,3
1414         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1415       enddo
1416       do k=1,3
1417         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1418      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1419      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1420         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1421      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1422      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1423       enddo
1424 C
1425 C Calculate the components of the gradient in DC and X
1426 C
1427       do k=i,j-1
1428         do l=1,3
1429           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1430         enddo
1431       enddo
1432       return
1433       end
1434 c------------------------------------------------------------------------------
1435       subroutine vec_and_deriv
1436       implicit real*8 (a-h,o-z)
1437       include 'DIMENSIONS'
1438       include 'DIMENSIONS.ZSCOPT'
1439       include 'COMMON.IOUNITS'
1440       include 'COMMON.GEO'
1441       include 'COMMON.VAR'
1442       include 'COMMON.LOCAL'
1443       include 'COMMON.CHAIN'
1444       include 'COMMON.VECTORS'
1445       include 'COMMON.DERIV'
1446       include 'COMMON.INTERACT'
1447       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1448 C Compute the local reference systems. For reference system (i), the
1449 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1450 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1451       do i=1,nres-1
1452 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1453           if (i.eq.nres-1) then
1454 C Case of the last full residue
1455 C Compute the Z-axis
1456             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1457             costh=dcos(pi-theta(nres))
1458             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1459             do k=1,3
1460               uz(k,i)=fac*uz(k,i)
1461             enddo
1462             if (calc_grad) then
1463 C Compute the derivatives of uz
1464             uzder(1,1,1)= 0.0d0
1465             uzder(2,1,1)=-dc_norm(3,i-1)
1466             uzder(3,1,1)= dc_norm(2,i-1)
1467             uzder(1,2,1)= dc_norm(3,i-1)
1468             uzder(2,2,1)= 0.0d0
1469             uzder(3,2,1)=-dc_norm(1,i-1)
1470             uzder(1,3,1)=-dc_norm(2,i-1)
1471             uzder(2,3,1)= dc_norm(1,i-1)
1472             uzder(3,3,1)= 0.0d0
1473             uzder(1,1,2)= 0.0d0
1474             uzder(2,1,2)= dc_norm(3,i)
1475             uzder(3,1,2)=-dc_norm(2,i)
1476             uzder(1,2,2)=-dc_norm(3,i)
1477             uzder(2,2,2)= 0.0d0
1478             uzder(3,2,2)= dc_norm(1,i)
1479             uzder(1,3,2)= dc_norm(2,i)
1480             uzder(2,3,2)=-dc_norm(1,i)
1481             uzder(3,3,2)= 0.0d0
1482             endif
1483 C Compute the Y-axis
1484             facy=fac
1485             do k=1,3
1486               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1487             enddo
1488             if (calc_grad) then
1489 C Compute the derivatives of uy
1490             do j=1,3
1491               do k=1,3
1492                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1493      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1494                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1495               enddo
1496               uyder(j,j,1)=uyder(j,j,1)-costh
1497               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1498             enddo
1499             do j=1,2
1500               do k=1,3
1501                 do l=1,3
1502                   uygrad(l,k,j,i)=uyder(l,k,j)
1503                   uzgrad(l,k,j,i)=uzder(l,k,j)
1504                 enddo
1505               enddo
1506             enddo
1507             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1508             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1509             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1510             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1511             endif
1512           else
1513 C Other residues
1514 C Compute the Z-axis
1515             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1516             costh=dcos(pi-theta(i+2))
1517             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1518             do k=1,3
1519               uz(k,i)=fac*uz(k,i)
1520             enddo
1521             if (calc_grad) then
1522 C Compute the derivatives of uz
1523             uzder(1,1,1)= 0.0d0
1524             uzder(2,1,1)=-dc_norm(3,i+1)
1525             uzder(3,1,1)= dc_norm(2,i+1)
1526             uzder(1,2,1)= dc_norm(3,i+1)
1527             uzder(2,2,1)= 0.0d0
1528             uzder(3,2,1)=-dc_norm(1,i+1)
1529             uzder(1,3,1)=-dc_norm(2,i+1)
1530             uzder(2,3,1)= dc_norm(1,i+1)
1531             uzder(3,3,1)= 0.0d0
1532             uzder(1,1,2)= 0.0d0
1533             uzder(2,1,2)= dc_norm(3,i)
1534             uzder(3,1,2)=-dc_norm(2,i)
1535             uzder(1,2,2)=-dc_norm(3,i)
1536             uzder(2,2,2)= 0.0d0
1537             uzder(3,2,2)= dc_norm(1,i)
1538             uzder(1,3,2)= dc_norm(2,i)
1539             uzder(2,3,2)=-dc_norm(1,i)
1540             uzder(3,3,2)= 0.0d0
1541             endif
1542 C Compute the Y-axis
1543             facy=fac
1544             do k=1,3
1545               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1546             enddo
1547             if (calc_grad) then
1548 C Compute the derivatives of uy
1549             do j=1,3
1550               do k=1,3
1551                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1552      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1553                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1554               enddo
1555               uyder(j,j,1)=uyder(j,j,1)-costh
1556               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1557             enddo
1558             do j=1,2
1559               do k=1,3
1560                 do l=1,3
1561                   uygrad(l,k,j,i)=uyder(l,k,j)
1562                   uzgrad(l,k,j,i)=uzder(l,k,j)
1563                 enddo
1564               enddo
1565             enddo
1566             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1567             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1568             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1569             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1570           endif
1571           endif
1572       enddo
1573       if (calc_grad) then
1574       do i=1,nres-1
1575         vbld_inv_temp(1)=vbld_inv(i+1)
1576         if (i.lt.nres-1) then
1577           vbld_inv_temp(2)=vbld_inv(i+2)
1578         else
1579           vbld_inv_temp(2)=vbld_inv(i)
1580         endif
1581         do j=1,2
1582           do k=1,3
1583             do l=1,3
1584               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1585               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1586             enddo
1587           enddo
1588         enddo
1589       enddo
1590       endif
1591       return
1592       end
1593 C-----------------------------------------------------------------------------
1594       subroutine vec_and_deriv_test
1595       implicit real*8 (a-h,o-z)
1596       include 'DIMENSIONS'
1597       include 'DIMENSIONS.ZSCOPT'
1598       include 'COMMON.IOUNITS'
1599       include 'COMMON.GEO'
1600       include 'COMMON.VAR'
1601       include 'COMMON.LOCAL'
1602       include 'COMMON.CHAIN'
1603       include 'COMMON.VECTORS'
1604       dimension uyder(3,3,2),uzder(3,3,2)
1605 C Compute the local reference systems. For reference system (i), the
1606 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1607 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1608       do i=1,nres-1
1609           if (i.eq.nres-1) then
1610 C Case of the last full residue
1611 C Compute the Z-axis
1612             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1613             costh=dcos(pi-theta(nres))
1614             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1615 c            write (iout,*) 'fac',fac,
1616 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1617             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1618             do k=1,3
1619               uz(k,i)=fac*uz(k,i)
1620             enddo
1621 C Compute the derivatives of uz
1622             uzder(1,1,1)= 0.0d0
1623             uzder(2,1,1)=-dc_norm(3,i-1)
1624             uzder(3,1,1)= dc_norm(2,i-1)
1625             uzder(1,2,1)= dc_norm(3,i-1)
1626             uzder(2,2,1)= 0.0d0
1627             uzder(3,2,1)=-dc_norm(1,i-1)
1628             uzder(1,3,1)=-dc_norm(2,i-1)
1629             uzder(2,3,1)= dc_norm(1,i-1)
1630             uzder(3,3,1)= 0.0d0
1631             uzder(1,1,2)= 0.0d0
1632             uzder(2,1,2)= dc_norm(3,i)
1633             uzder(3,1,2)=-dc_norm(2,i)
1634             uzder(1,2,2)=-dc_norm(3,i)
1635             uzder(2,2,2)= 0.0d0
1636             uzder(3,2,2)= dc_norm(1,i)
1637             uzder(1,3,2)= dc_norm(2,i)
1638             uzder(2,3,2)=-dc_norm(1,i)
1639             uzder(3,3,2)= 0.0d0
1640 C Compute the Y-axis
1641             do k=1,3
1642               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1643             enddo
1644             facy=fac
1645             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1646      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1647      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1648             do k=1,3
1649 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1650               uy(k,i)=
1651 c     &        facy*(
1652      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1653      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1654 c     &        )
1655             enddo
1656 c            write (iout,*) 'facy',facy,
1657 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1658             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1659             do k=1,3
1660               uy(k,i)=facy*uy(k,i)
1661             enddo
1662 C Compute the derivatives of uy
1663             do j=1,3
1664               do k=1,3
1665                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1666      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1667                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1668               enddo
1669 c              uyder(j,j,1)=uyder(j,j,1)-costh
1670 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1671               uyder(j,j,1)=uyder(j,j,1)
1672      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1673               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1674      &          +uyder(j,j,2)
1675             enddo
1676             do j=1,2
1677               do k=1,3
1678                 do l=1,3
1679                   uygrad(l,k,j,i)=uyder(l,k,j)
1680                   uzgrad(l,k,j,i)=uzder(l,k,j)
1681                 enddo
1682               enddo
1683             enddo
1684             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1685             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1686             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1687             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1688           else
1689 C Other residues
1690 C Compute the Z-axis
1691             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1692             costh=dcos(pi-theta(i+2))
1693             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1694             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1695             do k=1,3
1696               uz(k,i)=fac*uz(k,i)
1697             enddo
1698 C Compute the derivatives of uz
1699             uzder(1,1,1)= 0.0d0
1700             uzder(2,1,1)=-dc_norm(3,i+1)
1701             uzder(3,1,1)= dc_norm(2,i+1)
1702             uzder(1,2,1)= dc_norm(3,i+1)
1703             uzder(2,2,1)= 0.0d0
1704             uzder(3,2,1)=-dc_norm(1,i+1)
1705             uzder(1,3,1)=-dc_norm(2,i+1)
1706             uzder(2,3,1)= dc_norm(1,i+1)
1707             uzder(3,3,1)= 0.0d0
1708             uzder(1,1,2)= 0.0d0
1709             uzder(2,1,2)= dc_norm(3,i)
1710             uzder(3,1,2)=-dc_norm(2,i)
1711             uzder(1,2,2)=-dc_norm(3,i)
1712             uzder(2,2,2)= 0.0d0
1713             uzder(3,2,2)= dc_norm(1,i)
1714             uzder(1,3,2)= dc_norm(2,i)
1715             uzder(2,3,2)=-dc_norm(1,i)
1716             uzder(3,3,2)= 0.0d0
1717 C Compute the Y-axis
1718             facy=fac
1719             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1720      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1721      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1722             do k=1,3
1723 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1724               uy(k,i)=
1725 c     &        facy*(
1726      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1727      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1728 c     &        )
1729             enddo
1730 c            write (iout,*) 'facy',facy,
1731 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1732             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1733             do k=1,3
1734               uy(k,i)=facy*uy(k,i)
1735             enddo
1736 C Compute the derivatives of uy
1737             do j=1,3
1738               do k=1,3
1739                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1740      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1741                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1742               enddo
1743 c              uyder(j,j,1)=uyder(j,j,1)-costh
1744 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1745               uyder(j,j,1)=uyder(j,j,1)
1746      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1747               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1748      &          +uyder(j,j,2)
1749             enddo
1750             do j=1,2
1751               do k=1,3
1752                 do l=1,3
1753                   uygrad(l,k,j,i)=uyder(l,k,j)
1754                   uzgrad(l,k,j,i)=uzder(l,k,j)
1755                 enddo
1756               enddo
1757             enddo
1758             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1759             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1760             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1761             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1762           endif
1763       enddo
1764       do i=1,nres-1
1765         do j=1,2
1766           do k=1,3
1767             do l=1,3
1768               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1769               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1770             enddo
1771           enddo
1772         enddo
1773       enddo
1774       return
1775       end
1776 C-----------------------------------------------------------------------------
1777       subroutine check_vecgrad
1778       implicit real*8 (a-h,o-z)
1779       include 'DIMENSIONS'
1780       include 'DIMENSIONS.ZSCOPT'
1781       include 'COMMON.IOUNITS'
1782       include 'COMMON.GEO'
1783       include 'COMMON.VAR'
1784       include 'COMMON.LOCAL'
1785       include 'COMMON.CHAIN'
1786       include 'COMMON.VECTORS'
1787       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1788       dimension uyt(3,maxres),uzt(3,maxres)
1789       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1790       double precision delta /1.0d-7/
1791       call vec_and_deriv
1792 cd      do i=1,nres
1793 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1794 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1795 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1796 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1797 cd     &     (dc_norm(if90,i),if90=1,3)
1798 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1799 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1800 cd          write(iout,'(a)')
1801 cd      enddo
1802       do i=1,nres
1803         do j=1,2
1804           do k=1,3
1805             do l=1,3
1806               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1807               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1808             enddo
1809           enddo
1810         enddo
1811       enddo
1812       call vec_and_deriv
1813       do i=1,nres
1814         do j=1,3
1815           uyt(j,i)=uy(j,i)
1816           uzt(j,i)=uz(j,i)
1817         enddo
1818       enddo
1819       do i=1,nres
1820 cd        write (iout,*) 'i=',i
1821         do k=1,3
1822           erij(k)=dc_norm(k,i)
1823         enddo
1824         do j=1,3
1825           do k=1,3
1826             dc_norm(k,i)=erij(k)
1827           enddo
1828           dc_norm(j,i)=dc_norm(j,i)+delta
1829 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1830 c          do k=1,3
1831 c            dc_norm(k,i)=dc_norm(k,i)/fac
1832 c          enddo
1833 c          write (iout,*) (dc_norm(k,i),k=1,3)
1834 c          write (iout,*) (erij(k),k=1,3)
1835           call vec_and_deriv
1836           do k=1,3
1837             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1838             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1839             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1840             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1841           enddo
1842 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1843 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1844 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1845         enddo
1846         do k=1,3
1847           dc_norm(k,i)=erij(k)
1848         enddo
1849 cd        do k=1,3
1850 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1851 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1852 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1853 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1854 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1855 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1856 cd          write (iout,'(a)')
1857 cd        enddo
1858       enddo
1859       return
1860       end
1861 C--------------------------------------------------------------------------
1862       subroutine set_matrices
1863       implicit real*8 (a-h,o-z)
1864       include 'DIMENSIONS'
1865       include 'DIMENSIONS.ZSCOPT'
1866       include 'COMMON.IOUNITS'
1867       include 'COMMON.GEO'
1868       include 'COMMON.VAR'
1869       include 'COMMON.LOCAL'
1870       include 'COMMON.CHAIN'
1871       include 'COMMON.DERIV'
1872       include 'COMMON.INTERACT'
1873       include 'COMMON.CONTACTS'
1874       include 'COMMON.TORSION'
1875       include 'COMMON.VECTORS'
1876       include 'COMMON.FFIELD'
1877       double precision auxvec(2),auxmat(2,2)
1878 C
1879 C Compute the virtual-bond-torsional-angle dependent quantities needed
1880 C to calculate the el-loc multibody terms of various order.
1881 C
1882       do i=3,nres+1
1883         if (i .lt. nres+1) then
1884           sin1=dsin(phi(i))
1885           cos1=dcos(phi(i))
1886           sintab(i-2)=sin1
1887           costab(i-2)=cos1
1888           obrot(1,i-2)=cos1
1889           obrot(2,i-2)=sin1
1890           sin2=dsin(2*phi(i))
1891           cos2=dcos(2*phi(i))
1892           sintab2(i-2)=sin2
1893           costab2(i-2)=cos2
1894           obrot2(1,i-2)=cos2
1895           obrot2(2,i-2)=sin2
1896           Ug(1,1,i-2)=-cos1
1897           Ug(1,2,i-2)=-sin1
1898           Ug(2,1,i-2)=-sin1
1899           Ug(2,2,i-2)= cos1
1900           Ug2(1,1,i-2)=-cos2
1901           Ug2(1,2,i-2)=-sin2
1902           Ug2(2,1,i-2)=-sin2
1903           Ug2(2,2,i-2)= cos2
1904         else
1905           costab(i-2)=1.0d0
1906           sintab(i-2)=0.0d0
1907           obrot(1,i-2)=1.0d0
1908           obrot(2,i-2)=0.0d0
1909           obrot2(1,i-2)=0.0d0
1910           obrot2(2,i-2)=0.0d0
1911           Ug(1,1,i-2)=1.0d0
1912           Ug(1,2,i-2)=0.0d0
1913           Ug(2,1,i-2)=0.0d0
1914           Ug(2,2,i-2)=1.0d0
1915           Ug2(1,1,i-2)=0.0d0
1916           Ug2(1,2,i-2)=0.0d0
1917           Ug2(2,1,i-2)=0.0d0
1918           Ug2(2,2,i-2)=0.0d0
1919         endif
1920         if (i .gt. 3 .and. i .lt. nres+1) then
1921           obrot_der(1,i-2)=-sin1
1922           obrot_der(2,i-2)= cos1
1923           Ugder(1,1,i-2)= sin1
1924           Ugder(1,2,i-2)=-cos1
1925           Ugder(2,1,i-2)=-cos1
1926           Ugder(2,2,i-2)=-sin1
1927           dwacos2=cos2+cos2
1928           dwasin2=sin2+sin2
1929           obrot2_der(1,i-2)=-dwasin2
1930           obrot2_der(2,i-2)= dwacos2
1931           Ug2der(1,1,i-2)= dwasin2
1932           Ug2der(1,2,i-2)=-dwacos2
1933           Ug2der(2,1,i-2)=-dwacos2
1934           Ug2der(2,2,i-2)=-dwasin2
1935         else
1936           obrot_der(1,i-2)=0.0d0
1937           obrot_der(2,i-2)=0.0d0
1938           Ugder(1,1,i-2)=0.0d0
1939           Ugder(1,2,i-2)=0.0d0
1940           Ugder(2,1,i-2)=0.0d0
1941           Ugder(2,2,i-2)=0.0d0
1942           obrot2_der(1,i-2)=0.0d0
1943           obrot2_der(2,i-2)=0.0d0
1944           Ug2der(1,1,i-2)=0.0d0
1945           Ug2der(1,2,i-2)=0.0d0
1946           Ug2der(2,1,i-2)=0.0d0
1947           Ug2der(2,2,i-2)=0.0d0
1948         endif
1949         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1950           if (itype(i-2).le.ntyp) then
1951             iti = itortyp(itype(i-2))
1952           else
1953             iti=ntortyp+1
1954           endif
1955         else
1956           iti=ntortyp+1
1957         endif
1958         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1959           if (itype(i-1).le.ntyp) then
1960             iti1 = itortyp(itype(i-1))
1961           else
1962             iti1=ntortyp+1
1963           endif
1964         else
1965           iti1=ntortyp+1
1966         endif
1967 cd        write (iout,*) '*******i',i,' iti1',iti
1968 cd        write (iout,*) 'b1',b1(:,iti)
1969 cd        write (iout,*) 'b2',b2(:,iti)
1970 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1971 c        print *,"itilde1 i iti iti1",i,iti,iti1
1972         if (i .gt. iatel_s+2) then
1973           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1974           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1975           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1976           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1977           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1978           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1979           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1980         else
1981           do k=1,2
1982             Ub2(k,i-2)=0.0d0
1983             Ctobr(k,i-2)=0.0d0
1984             Dtobr2(k,i-2)=0.0d0
1985             do l=1,2
1986               EUg(l,k,i-2)=0.0d0
1987               CUg(l,k,i-2)=0.0d0
1988               DUg(l,k,i-2)=0.0d0
1989               DtUg2(l,k,i-2)=0.0d0
1990             enddo
1991           enddo
1992         endif
1993 c        print *,"itilde2 i iti iti1",i,iti,iti1
1994         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1995         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1996         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1997         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1998         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1999         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2000         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2001 c        print *,"itilde3 i iti iti1",i,iti,iti1
2002         do k=1,2
2003           muder(k,i-2)=Ub2der(k,i-2)
2004         enddo
2005         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2006           if (itype(i-1).le.ntyp) then
2007             iti1 = itortyp(itype(i-1))
2008           else
2009             iti1=ntortyp+1
2010           endif
2011         else
2012           iti1=ntortyp+1
2013         endif
2014         do k=1,2
2015           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2016         enddo
2017 C        write (iout,*) 'mumu',i,b1(1,iti),Ub2(1,i-2)
2018
2019 C Vectors and matrices dependent on a single virtual-bond dihedral.
2020         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2021         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2022         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2023         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2024         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2025         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2026         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2027         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2028         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2029 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2030 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2031       enddo
2032 C Matrices dependent on two consecutive virtual-bond dihedrals.
2033 C The order of matrices is from left to right.
2034       do i=2,nres-1
2035         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2036         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2037         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2038         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2039         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2040         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2041         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2042         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2043       enddo
2044 cd      do i=1,nres
2045 cd        iti = itortyp(itype(i))
2046 cd        write (iout,*) i
2047 cd        do j=1,2
2048 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2049 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2050 cd        enddo
2051 cd      enddo
2052       return
2053       end
2054 C--------------------------------------------------------------------------
2055       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2056 C
2057 C This subroutine calculates the average interaction energy and its gradient
2058 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2059 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2060 C The potential depends both on the distance of peptide-group centers and on
2061 C the orientation of the CA-CA virtual bonds.
2062 C
2063       implicit real*8 (a-h,o-z)
2064       include 'DIMENSIONS'
2065       include 'DIMENSIONS.ZSCOPT'
2066       include 'COMMON.CONTROL'
2067       include 'COMMON.IOUNITS'
2068       include 'COMMON.GEO'
2069       include 'COMMON.VAR'
2070       include 'COMMON.LOCAL'
2071       include 'COMMON.CHAIN'
2072       include 'COMMON.DERIV'
2073       include 'COMMON.INTERACT'
2074       include 'COMMON.CONTACTS'
2075       include 'COMMON.TORSION'
2076       include 'COMMON.VECTORS'
2077       include 'COMMON.FFIELD'
2078       include 'COMMON.SHIELD'
2079       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2080      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2081       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2082      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2083       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2084 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2085       double precision scal_el /0.5d0/
2086 C 12/13/98
2087 C 13-go grudnia roku pamietnego...
2088       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2089      &                   0.0d0,1.0d0,0.0d0,
2090      &                   0.0d0,0.0d0,1.0d0/
2091 cd      write(iout,*) 'In EELEC'
2092 cd      do i=1,nloctyp
2093 cd        write(iout,*) 'Type',i
2094 cd        write(iout,*) 'B1',B1(:,i)
2095 cd        write(iout,*) 'B2',B2(:,i)
2096 cd        write(iout,*) 'CC',CC(:,:,i)
2097 cd        write(iout,*) 'DD',DD(:,:,i)
2098 cd        write(iout,*) 'EE',EE(:,:,i)
2099 cd      enddo
2100 cd      call check_vecgrad
2101 cd      stop
2102       if (icheckgrad.eq.1) then
2103         do i=1,nres-1
2104           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2105           do k=1,3
2106             dc_norm(k,i)=dc(k,i)*fac
2107           enddo
2108 c          write (iout,*) 'i',i,' fac',fac
2109         enddo
2110       endif
2111       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2112      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2113      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2114 cd      if (wel_loc.gt.0.0d0) then
2115         if (icheckgrad.eq.1) then
2116         call vec_and_deriv_test
2117         else
2118         call vec_and_deriv
2119         endif
2120         call set_matrices
2121       endif
2122 cd      do i=1,nres-1
2123 cd        write (iout,*) 'i=',i
2124 cd        do k=1,3
2125 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2126 cd        enddo
2127 cd        do k=1,3
2128 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2129 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2130 cd        enddo
2131 cd      enddo
2132       num_conti_hb=0
2133       ees=0.0D0
2134       evdw1=0.0D0
2135       eel_loc=0.0d0
2136       eello_turn3=0.0d0
2137       eello_turn4=0.0d0
2138       ind=0
2139       do i=1,nres
2140         num_cont_hb(i)=0
2141       enddo
2142 C      print '(a)','Enter EELEC'
2143 C      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2144       do i=1,nres
2145         gel_loc_loc(i)=0.0d0
2146         gcorr_loc(i)=0.0d0
2147       enddo
2148       do i=iatel_s,iatel_e
2149 C          if (i.eq.1) then
2150            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2151 C     &  .or. itype(i+2).eq.ntyp1) cycle
2152 C          else
2153 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2154 C     &  .or. itype(i+2).eq.ntyp1
2155 C     &  .or. itype(i-1).eq.ntyp1
2156      &) cycle
2157 C         endif
2158         if (itel(i).eq.0) goto 1215
2159         dxi=dc(1,i)
2160         dyi=dc(2,i)
2161         dzi=dc(3,i)
2162         dx_normi=dc_norm(1,i)
2163         dy_normi=dc_norm(2,i)
2164         dz_normi=dc_norm(3,i)
2165         xmedi=c(1,i)+0.5d0*dxi
2166         ymedi=c(2,i)+0.5d0*dyi
2167         zmedi=c(3,i)+0.5d0*dzi
2168           xmedi=mod(xmedi,boxxsize)
2169           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2170           ymedi=mod(ymedi,boxysize)
2171           if (ymedi.lt.0) ymedi=ymedi+boxysize
2172           zmedi=mod(zmedi,boxzsize)
2173           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2174         num_conti=0
2175 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2176         do j=ielstart(i),ielend(i)
2177           if (j.le.1) cycle
2178 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2179 C     & .or.itype(j+2).eq.ntyp1
2180 C     &) cycle
2181 C          else
2182           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2183 C     & .or.itype(j+2).eq.ntyp1
2184 C     & .or.itype(j-1).eq.ntyp1
2185      &) cycle
2186 C         endif
2187 C
2188 C) cycle
2189           if (itel(j).eq.0) goto 1216
2190           ind=ind+1
2191           iteli=itel(i)
2192           itelj=itel(j)
2193           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2194           aaa=app(iteli,itelj)
2195           bbb=bpp(iteli,itelj)
2196 C Diagnostics only!!!
2197 c         aaa=0.0D0
2198 c         bbb=0.0D0
2199 c         ael6i=0.0D0
2200 c         ael3i=0.0D0
2201 C End diagnostics
2202           ael6i=ael6(iteli,itelj)
2203           ael3i=ael3(iteli,itelj)
2204           dxj=dc(1,j)
2205           dyj=dc(2,j)
2206           dzj=dc(3,j)
2207           dx_normj=dc_norm(1,j)
2208           dy_normj=dc_norm(2,j)
2209           dz_normj=dc_norm(3,j)
2210           xj=c(1,j)+0.5D0*dxj
2211           yj=c(2,j)+0.5D0*dyj
2212           zj=c(3,j)+0.5D0*dzj
2213          xj=mod(xj,boxxsize)
2214           if (xj.lt.0) xj=xj+boxxsize
2215           yj=mod(yj,boxysize)
2216           if (yj.lt.0) yj=yj+boxysize
2217           zj=mod(zj,boxzsize)
2218           if (zj.lt.0) zj=zj+boxzsize
2219       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2220       xj_safe=xj
2221       yj_safe=yj
2222       zj_safe=zj
2223       isubchap=0
2224       do xshift=-1,1
2225       do yshift=-1,1
2226       do zshift=-1,1
2227           xj=xj_safe+xshift*boxxsize
2228           yj=yj_safe+yshift*boxysize
2229           zj=zj_safe+zshift*boxzsize
2230           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2231           if(dist_temp.lt.dist_init) then
2232             dist_init=dist_temp
2233             xj_temp=xj
2234             yj_temp=yj
2235             zj_temp=zj
2236             isubchap=1
2237           endif
2238        enddo
2239        enddo
2240        enddo
2241        if (isubchap.eq.1) then
2242           xj=xj_temp-xmedi
2243           yj=yj_temp-ymedi
2244           zj=zj_temp-zmedi
2245        else
2246           xj=xj_safe-xmedi
2247           yj=yj_safe-ymedi
2248           zj=zj_safe-zmedi
2249        endif
2250           rij=xj*xj+yj*yj+zj*zj
2251             sss=sscale(sqrt(rij))
2252             sssgrad=sscagrad(sqrt(rij))
2253           rrmij=1.0D0/rij
2254           rij=dsqrt(rij)
2255           rmij=1.0D0/rij
2256           r3ij=rrmij*rmij
2257           r6ij=r3ij*r3ij
2258           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2259           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2260           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2261           fac=cosa-3.0D0*cosb*cosg
2262           ev1=aaa*r6ij*r6ij
2263 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2264           if (j.eq.i+2) ev1=scal_el*ev1
2265           ev2=bbb*r6ij
2266           fac3=ael6i*r6ij
2267           fac4=ael3i*r3ij
2268           evdwij=ev1+ev2
2269           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2270           el2=fac4*fac
2271           eesij=el1+el2
2272 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2273 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2274           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2275           if (shield_mode.gt.0) then
2276 C          fac_shield(i)=0.4
2277 C          fac_shield(j)=0.6
2278           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2279           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2280           eesij=(el1+el2)
2281           ees=ees+eesij
2282           else
2283           fac_shield(i)=1.0
2284           fac_shield(j)=1.0
2285           eesij=(el1+el2)
2286           ees=ees+eesij
2287           endif
2288           evdw1=evdw1+evdwij*sss
2289 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2290 c     &'evdw1',i,j,evdwij
2291 c     &,iteli,itelj,aaa,evdw1
2292
2293 C              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2294 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2295 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2296 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2297 c     &      xmedi,ymedi,zmedi,xj,yj,zj
2298 C
2299 C Calculate contributions to the Cartesian gradient.
2300 C
2301 #ifdef SPLITELE
2302           facvdw=-6*rrmij*(ev1+evdwij)*sss
2303           facel=-3*rrmij*(el1+eesij)
2304           fac1=fac
2305           erij(1)=xj*rmij
2306           erij(2)=yj*rmij
2307           erij(3)=zj*rmij
2308           if (calc_grad) then
2309 *
2310 * Radial derivatives. First process both termini of the fragment (i,j)
2311 *
2312           ggg(1)=facel*xj
2313           ggg(2)=facel*yj
2314           ggg(3)=facel*zj
2315           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2316      &  (shield_mode.gt.0)) then
2317 C          print *,i,j
2318           do ilist=1,ishield_list(i)
2319            iresshield=shield_list(ilist,i)
2320            do k=1,3
2321            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2322      &      *2.0
2323            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2324      &              rlocshield
2325      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2326             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2327 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2328 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2329 C             if (iresshield.gt.i) then
2330 C               do ishi=i+1,iresshield-1
2331 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2332 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2333 C
2334 C              enddo
2335 C             else
2336 C               do ishi=iresshield,i
2337 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2338 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2339 C
2340 C               enddo
2341 C              endif
2342            enddo
2343           enddo
2344           do ilist=1,ishield_list(j)
2345            iresshield=shield_list(ilist,j)
2346            do k=1,3
2347            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2348      &     *2.0
2349            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2350      &              rlocshield
2351      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2352            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2353            enddo
2354           enddo
2355
2356           do k=1,3
2357             gshieldc(k,i)=gshieldc(k,i)+
2358      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2359             gshieldc(k,j)=gshieldc(k,j)+
2360      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2361             gshieldc(k,i-1)=gshieldc(k,i-1)+
2362      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2363             gshieldc(k,j-1)=gshieldc(k,j-1)+
2364      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2365
2366            enddo
2367            endif
2368
2369           do k=1,3
2370             ghalf=0.5D0*ggg(k)
2371             gelc(k,i)=gelc(k,i)+ghalf
2372             gelc(k,j)=gelc(k,j)+ghalf
2373           enddo
2374 *
2375 * Loop over residues i+1 thru j-1.
2376 *
2377           do k=i+1,j-1
2378             do l=1,3
2379               gelc(l,k)=gelc(l,k)+ggg(l)
2380             enddo
2381           enddo
2382 C          ggg(1)=facvdw*xj
2383 C          ggg(2)=facvdw*yj
2384 C          ggg(3)=facvdw*zj
2385           if (sss.gt.0.0) then
2386           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2387           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2388           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2389           else
2390           ggg(1)=0.0
2391           ggg(2)=0.0
2392           ggg(3)=0.0
2393           endif
2394           do k=1,3
2395             ghalf=0.5D0*ggg(k)
2396             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2397             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2398           enddo
2399 *
2400 * Loop over residues i+1 thru j-1.
2401 *
2402           do k=i+1,j-1
2403             do l=1,3
2404               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2405             enddo
2406           enddo
2407 #else
2408           facvdw=(ev1+evdwij)*sss
2409           facel=el1+eesij
2410           fac1=fac
2411           fac=-3*rrmij*(facvdw+facvdw+facel)
2412           erij(1)=xj*rmij
2413           erij(2)=yj*rmij
2414           erij(3)=zj*rmij
2415           if (calc_grad) then
2416 *
2417 * Radial derivatives. First process both termini of the fragment (i,j)
2418 *
2419           ggg(1)=fac*xj
2420           ggg(2)=fac*yj
2421           ggg(3)=fac*zj
2422           do k=1,3
2423             ghalf=0.5D0*ggg(k)
2424             gelc(k,i)=gelc(k,i)+ghalf
2425             gelc(k,j)=gelc(k,j)+ghalf
2426           enddo
2427 *
2428 * Loop over residues i+1 thru j-1.
2429 *
2430           do k=i+1,j-1
2431             do l=1,3
2432               gelc(l,k)=gelc(l,k)+ggg(l)
2433             enddo
2434           enddo
2435 #endif
2436 *
2437 * Angular part
2438 *
2439           ecosa=2.0D0*fac3*fac1+fac4
2440           fac4=-3.0D0*fac4
2441           fac3=-6.0D0*fac3
2442           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2443           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2444           do k=1,3
2445             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2446             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2447           enddo
2448 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2449 cd   &          (dcosg(k),k=1,3)
2450           do k=1,3
2451             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2452      &      *fac_shield(i)**2*fac_shield(j)**2
2453           enddo
2454           do k=1,3
2455             ghalf=0.5D0*ggg(k)
2456             gelc(k,i)=gelc(k,i)+ghalf
2457      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2458      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2459      &           *fac_shield(i)**2*fac_shield(j)**2
2460
2461             gelc(k,j)=gelc(k,j)+ghalf
2462      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2463      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2464      &           *fac_shield(i)**2*fac_shield(j)**2
2465           enddo
2466           do k=i+1,j-1
2467             do l=1,3
2468               gelc(l,k)=gelc(l,k)+ggg(l)
2469             enddo
2470           enddo
2471           endif
2472
2473           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2474      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2475      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2476 C
2477 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2478 C   energy of a peptide unit is assumed in the form of a second-order
2479 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2480 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2481 C   are computed for EVERY pair of non-contiguous peptide groups.
2482 C
2483           if (j.lt.nres-1) then
2484             j1=j+1
2485             j2=j-1
2486           else
2487             j1=j-1
2488             j2=j-2
2489           endif
2490           kkk=0
2491           do k=1,2
2492             do l=1,2
2493               kkk=kkk+1
2494               muij(kkk)=mu(k,i)*mu(l,j)
2495             enddo
2496           enddo
2497 cd         write (iout,*) 'EELEC: i',i,' j',j
2498 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2499 cd          write(iout,*) 'muij',muij
2500           ury=scalar(uy(1,i),erij)
2501           urz=scalar(uz(1,i),erij)
2502           vry=scalar(uy(1,j),erij)
2503           vrz=scalar(uz(1,j),erij)
2504           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2505           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2506           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2507           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2508 C For diagnostics only
2509 cd          a22=1.0d0
2510 cd          a23=1.0d0
2511 cd          a32=1.0d0
2512 cd          a33=1.0d0
2513           fac=dsqrt(-ael6i)*r3ij
2514 cd          write (2,*) 'fac=',fac
2515 C For diagnostics only
2516 cd          fac=1.0d0
2517           a22=a22*fac
2518           a23=a23*fac
2519           a32=a32*fac
2520           a33=a33*fac
2521 cd          write (iout,'(4i5,4f10.5)')
2522 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2523 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2524 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2525 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2526 cd          write (iout,'(4f10.5)')
2527 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2528 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2529 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2530 cd           write (iout,'(2i3,9f10.5/)') i,j,
2531 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2532           if (calc_grad) then
2533 C Derivatives of the elements of A in virtual-bond vectors
2534           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2535 cd          do k=1,3
2536 cd            do l=1,3
2537 cd              erder(k,l)=0.0d0
2538 cd            enddo
2539 cd          enddo
2540           do k=1,3
2541             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2542             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2543             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2544             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2545             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2546             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2547             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2548             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2549             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2550             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2551             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2552             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2553           enddo
2554 cd          do k=1,3
2555 cd            do l=1,3
2556 cd              uryg(k,l)=0.0d0
2557 cd              urzg(k,l)=0.0d0
2558 cd              vryg(k,l)=0.0d0
2559 cd              vrzg(k,l)=0.0d0
2560 cd            enddo
2561 cd          enddo
2562 C Compute radial contributions to the gradient
2563           facr=-3.0d0*rrmij
2564           a22der=a22*facr
2565           a23der=a23*facr
2566           a32der=a32*facr
2567           a33der=a33*facr
2568 cd          a22der=0.0d0
2569 cd          a23der=0.0d0
2570 cd          a32der=0.0d0
2571 cd          a33der=0.0d0
2572           agg(1,1)=a22der*xj
2573           agg(2,1)=a22der*yj
2574           agg(3,1)=a22der*zj
2575           agg(1,2)=a23der*xj
2576           agg(2,2)=a23der*yj
2577           agg(3,2)=a23der*zj
2578           agg(1,3)=a32der*xj
2579           agg(2,3)=a32der*yj
2580           agg(3,3)=a32der*zj
2581           agg(1,4)=a33der*xj
2582           agg(2,4)=a33der*yj
2583           agg(3,4)=a33der*zj
2584 C Add the contributions coming from er
2585           fac3=-3.0d0*fac
2586           do k=1,3
2587             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2588             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2589             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2590             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2591           enddo
2592           do k=1,3
2593 C Derivatives in DC(i)
2594             ghalf1=0.5d0*agg(k,1)
2595             ghalf2=0.5d0*agg(k,2)
2596             ghalf3=0.5d0*agg(k,3)
2597             ghalf4=0.5d0*agg(k,4)
2598             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2599      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2600             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2601      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2602             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2603      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2604             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2605      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2606 C Derivatives in DC(i+1)
2607             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2608      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2609             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2610      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2611             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2612      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2613             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2614      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2615 C Derivatives in DC(j)
2616             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2617      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2618             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2619      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2620             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2621      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2622             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2623      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2624 C Derivatives in DC(j+1) or DC(nres-1)
2625             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2626      &      -3.0d0*vryg(k,3)*ury)
2627             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2628      &      -3.0d0*vrzg(k,3)*ury)
2629             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2630      &      -3.0d0*vryg(k,3)*urz)
2631             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2632      &      -3.0d0*vrzg(k,3)*urz)
2633 cd            aggi(k,1)=ghalf1
2634 cd            aggi(k,2)=ghalf2
2635 cd            aggi(k,3)=ghalf3
2636 cd            aggi(k,4)=ghalf4
2637 C Derivatives in DC(i+1)
2638 cd            aggi1(k,1)=agg(k,1)
2639 cd            aggi1(k,2)=agg(k,2)
2640 cd            aggi1(k,3)=agg(k,3)
2641 cd            aggi1(k,4)=agg(k,4)
2642 C Derivatives in DC(j)
2643 cd            aggj(k,1)=ghalf1
2644 cd            aggj(k,2)=ghalf2
2645 cd            aggj(k,3)=ghalf3
2646 cd            aggj(k,4)=ghalf4
2647 C Derivatives in DC(j+1)
2648 cd            aggj1(k,1)=0.0d0
2649 cd            aggj1(k,2)=0.0d0
2650 cd            aggj1(k,3)=0.0d0
2651 cd            aggj1(k,4)=0.0d0
2652             if (j.eq.nres-1 .and. i.lt.j-2) then
2653               do l=1,4
2654                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2655 cd                aggj1(k,l)=agg(k,l)
2656               enddo
2657             endif
2658           enddo
2659           endif
2660 c          goto 11111
2661 C Check the loc-el terms by numerical integration
2662           acipa(1,1)=a22
2663           acipa(1,2)=a23
2664           acipa(2,1)=a32
2665           acipa(2,2)=a33
2666           a22=-a22
2667           a23=-a23
2668           do l=1,2
2669             do k=1,3
2670               agg(k,l)=-agg(k,l)
2671               aggi(k,l)=-aggi(k,l)
2672               aggi1(k,l)=-aggi1(k,l)
2673               aggj(k,l)=-aggj(k,l)
2674               aggj1(k,l)=-aggj1(k,l)
2675             enddo
2676           enddo
2677           if (j.lt.nres-1) then
2678             a22=-a22
2679             a32=-a32
2680             do l=1,3,2
2681               do k=1,3
2682                 agg(k,l)=-agg(k,l)
2683                 aggi(k,l)=-aggi(k,l)
2684                 aggi1(k,l)=-aggi1(k,l)
2685                 aggj(k,l)=-aggj(k,l)
2686                 aggj1(k,l)=-aggj1(k,l)
2687               enddo
2688             enddo
2689           else
2690             a22=-a22
2691             a23=-a23
2692             a32=-a32
2693             a33=-a33
2694             do l=1,4
2695               do k=1,3
2696                 agg(k,l)=-agg(k,l)
2697                 aggi(k,l)=-aggi(k,l)
2698                 aggi1(k,l)=-aggi1(k,l)
2699                 aggj(k,l)=-aggj(k,l)
2700                 aggj1(k,l)=-aggj1(k,l)
2701               enddo
2702             enddo
2703           endif
2704           ENDIF ! WCORR
2705 11111     continue
2706           IF (wel_loc.gt.0.0d0) THEN
2707 C Contribution to the local-electrostatic energy coming from the i-j pair
2708           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2709      &     +a33*muij(4)
2710           if (shield_mode.eq.0) then
2711            fac_shield(i)=1.0
2712            fac_shield(j)=1.0
2713 C          else
2714 C           fac_shield(i)=0.4
2715 C           fac_shield(j)=0.6
2716           endif
2717           eel_loc_ij=eel_loc_ij
2718      &    *fac_shield(i)*fac_shield(j)
2719 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2720 C          write (iout,'(a6,2i5,0pf7.3)')
2721 C     &            'eelloc',i,j,eel_loc_ij
2722 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2723 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2724 C          eel_loc=eel_loc+eel_loc_ij
2725           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2726      &  (shield_mode.gt.0)) then
2727 C          print *,i,j
2728
2729           do ilist=1,ishield_list(i)
2730            iresshield=shield_list(ilist,i)
2731            do k=1,3
2732            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2733      &                                          /fac_shield(i)
2734 C     &      *2.0
2735            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2736      &              rlocshield
2737      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2738             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2739      &      +rlocshield
2740            enddo
2741           enddo
2742           do ilist=1,ishield_list(j)
2743            iresshield=shield_list(ilist,j)
2744            do k=1,3
2745            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2746      &                                       /fac_shield(j)
2747 C     &     *2.0
2748            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2749      &              rlocshield
2750      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2751            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2752      &             +rlocshield
2753
2754            enddo
2755           enddo
2756           do k=1,3
2757             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2758      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2759             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2760      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2761             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2762      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2763             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2764      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2765            enddo
2766            endif
2767           eel_loc=eel_loc+eel_loc_ij
2768
2769 C Partial derivatives in virtual-bond dihedral angles gamma
2770           if (calc_grad) then
2771           if (i.gt.1)
2772      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2773      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2774      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
2775      &    *fac_shield(i)*fac_shield(j)
2776
2777           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2778      &            (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2779      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
2780      &    *fac_shield(i)*fac_shield(j)
2781
2782 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2783 cd          write(iout,*) 'agg  ',agg
2784 cd          write(iout,*) 'aggi ',aggi
2785 cd          write(iout,*) 'aggi1',aggi1
2786 cd          write(iout,*) 'aggj ',aggj
2787 cd          write(iout,*) 'aggj1',aggj1
2788
2789 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2790           do l=1,3
2791             ggg(l)=(agg(l,1)*muij(1)+
2792      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
2793      &    *fac_shield(i)*fac_shield(j)
2794
2795           enddo
2796           do k=i+2,j2
2797             do l=1,3
2798               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2799             enddo
2800           enddo
2801 C Remaining derivatives of eello
2802           do l=1,3
2803             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
2804      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
2805      &    *fac_shield(i)*fac_shield(j)
2806
2807             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
2808      &         aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
2809      &    *fac_shield(i)*fac_shield(j)
2810
2811             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
2812      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
2813      &    *fac_shield(i)*fac_shield(j)
2814
2815             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
2816      &         aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
2817      &    *fac_shield(i)*fac_shield(j)
2818
2819           enddo
2820           endif
2821           ENDIF
2822           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2823 C Contributions from turns
2824             a_temp(1,1)=a22
2825             a_temp(1,2)=a23
2826             a_temp(2,1)=a32
2827             a_temp(2,2)=a33
2828             call eturn34(i,j,eello_turn3,eello_turn4)
2829           endif
2830 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2831           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2832 C
2833 C Calculate the contact function. The ith column of the array JCONT will
2834 C contain the numbers of atoms that make contacts with the atom I (of numbers
2835 C greater than I). The arrays FACONT and GACONT will contain the values of
2836 C the contact function and its derivative.
2837 c           r0ij=1.02D0*rpp(iteli,itelj)
2838 c           r0ij=1.11D0*rpp(iteli,itelj)
2839             r0ij=2.20D0*rpp(iteli,itelj)
2840 c           r0ij=1.55D0*rpp(iteli,itelj)
2841             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2842             if (fcont.gt.0.0D0) then
2843               num_conti=num_conti+1
2844               if (num_conti.gt.maxconts) then
2845                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2846      &                         ' will skip next contacts for this conf.'
2847               else
2848                 jcont_hb(num_conti,i)=j
2849                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2850      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2851 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2852 C  terms.
2853                 d_cont(num_conti,i)=rij
2854 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2855 C     --- Electrostatic-interaction matrix ---
2856                 a_chuj(1,1,num_conti,i)=a22
2857                 a_chuj(1,2,num_conti,i)=a23
2858                 a_chuj(2,1,num_conti,i)=a32
2859                 a_chuj(2,2,num_conti,i)=a33
2860 C     --- Gradient of rij
2861                 do kkk=1,3
2862                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2863                 enddo
2864 c             if (i.eq.1) then
2865 c                a_chuj(1,1,num_conti,i)=-0.61d0
2866 c                a_chuj(1,2,num_conti,i)= 0.4d0
2867 c                a_chuj(2,1,num_conti,i)= 0.65d0
2868 c                a_chuj(2,2,num_conti,i)= 0.50d0
2869 c             else if (i.eq.2) then
2870 c                a_chuj(1,1,num_conti,i)= 0.0d0
2871 c                a_chuj(1,2,num_conti,i)= 0.0d0
2872 c                a_chuj(2,1,num_conti,i)= 0.0d0
2873 c                a_chuj(2,2,num_conti,i)= 0.0d0
2874 c             endif
2875 C     --- and its gradients
2876 cd                write (iout,*) 'i',i,' j',j
2877 cd                do kkk=1,3
2878 cd                write (iout,*) 'iii 1 kkk',kkk
2879 cd                write (iout,*) agg(kkk,:)
2880 cd                enddo
2881 cd                do kkk=1,3
2882 cd                write (iout,*) 'iii 2 kkk',kkk
2883 cd                write (iout,*) aggi(kkk,:)
2884 cd                enddo
2885 cd                do kkk=1,3
2886 cd                write (iout,*) 'iii 3 kkk',kkk
2887 cd                write (iout,*) aggi1(kkk,:)
2888 cd                enddo
2889 cd                do kkk=1,3
2890 cd                write (iout,*) 'iii 4 kkk',kkk
2891 cd                write (iout,*) aggj(kkk,:)
2892 cd                enddo
2893 cd                do kkk=1,3
2894 cd                write (iout,*) 'iii 5 kkk',kkk
2895 cd                write (iout,*) aggj1(kkk,:)
2896 cd                enddo
2897                 kkll=0
2898                 do k=1,2
2899                   do l=1,2
2900                     kkll=kkll+1
2901                     do m=1,3
2902                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2903                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2904                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2905                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2906                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2907 c                      do mm=1,5
2908 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2909 c                      enddo
2910                     enddo
2911                   enddo
2912                 enddo
2913                 ENDIF
2914                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2915 C Calculate contact energies
2916                 cosa4=4.0D0*cosa
2917                 wij=cosa-3.0D0*cosb*cosg
2918                 cosbg1=cosb+cosg
2919                 cosbg2=cosb-cosg
2920 c               fac3=dsqrt(-ael6i)/r0ij**3
2921                 fac3=dsqrt(-ael6i)*r3ij
2922                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2923                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2924 c               ees0mij=0.0D0
2925                 if (shield_mode.eq.0) then
2926                 fac_shield(i)=1.0d0
2927                 fac_shield(j)=1.0d0
2928                 else
2929                 ees0plist(num_conti,i)=j
2930 C                fac_shield(i)=0.4d0
2931 C                fac_shield(j)=0.6d0
2932                 endif
2933                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2934      &          *fac_shield(i)*fac_shield(j)
2935
2936                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2937      &          *fac_shield(i)*fac_shield(j)
2938
2939 C Diagnostics. Comment out or remove after debugging!
2940 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2941 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2942 c               ees0m(num_conti,i)=0.0D0
2943 C End diagnostics.
2944 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2945 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2946                 facont_hb(num_conti,i)=fcont
2947                 if (calc_grad) then
2948 C Angular derivatives of the contact function
2949                 ees0pij1=fac3/ees0pij
2950                 ees0mij1=fac3/ees0mij
2951                 fac3p=-3.0D0*fac3*rrmij
2952                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2953                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2954 c               ees0mij1=0.0D0
2955                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2956                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2957                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2958                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2959                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2960                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2961                 ecosap=ecosa1+ecosa2
2962                 ecosbp=ecosb1+ecosb2
2963                 ecosgp=ecosg1+ecosg2
2964                 ecosam=ecosa1-ecosa2
2965                 ecosbm=ecosb1-ecosb2
2966                 ecosgm=ecosg1-ecosg2
2967 C Diagnostics
2968 c               ecosap=ecosa1
2969 c               ecosbp=ecosb1
2970 c               ecosgp=ecosg1
2971 c               ecosam=0.0D0
2972 c               ecosbm=0.0D0
2973 c               ecosgm=0.0D0
2974 C End diagnostics
2975                 fprimcont=fprimcont/rij
2976 cd              facont_hb(num_conti,i)=1.0D0
2977 C Following line is for diagnostics.
2978 cd              fprimcont=0.0D0
2979                 do k=1,3
2980                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2981                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2982                 enddo
2983                 do k=1,3
2984                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2985                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2986                 enddo
2987                 gggp(1)=gggp(1)+ees0pijp*xj
2988                 gggp(2)=gggp(2)+ees0pijp*yj
2989                 gggp(3)=gggp(3)+ees0pijp*zj
2990                 gggm(1)=gggm(1)+ees0mijp*xj
2991                 gggm(2)=gggm(2)+ees0mijp*yj
2992                 gggm(3)=gggm(3)+ees0mijp*zj
2993 C Derivatives due to the contact function
2994                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2995                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2996                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2997                 do k=1,3
2998                   ghalfp=0.5D0*gggp(k)
2999                   ghalfm=0.5D0*gggm(k)
3000                   gacontp_hb1(k,num_conti,i)=ghalfp
3001      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3002      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3003      &          *fac_shield(i)*fac_shield(j)
3004
3005                   gacontp_hb2(k,num_conti,i)=ghalfp
3006      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3007      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3008      &          *fac_shield(i)*fac_shield(j)
3009
3010                   gacontp_hb3(k,num_conti,i)=gggp(k)
3011      &          *fac_shield(i)*fac_shield(j)
3012
3013                   gacontm_hb1(k,num_conti,i)=ghalfm
3014      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3015      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3016      &          *fac_shield(i)*fac_shield(j)
3017
3018                   gacontm_hb2(k,num_conti,i)=ghalfm
3019      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3020      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3021      &          *fac_shield(i)*fac_shield(j)
3022
3023                   gacontm_hb3(k,num_conti,i)=gggm(k)
3024      &          *fac_shield(i)*fac_shield(j)
3025
3026                 enddo
3027                 endif
3028 C Diagnostics. Comment out or remove after debugging!
3029 cdiag           do k=1,3
3030 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3031 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3032 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3033 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3034 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3035 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3036 cdiag           enddo
3037               ENDIF ! wcorr
3038               endif  ! num_conti.le.maxconts
3039             endif  ! fcont.gt.0
3040           endif    ! j.gt.i+1
3041  1216     continue
3042         enddo ! j
3043         num_cont_hb(i)=num_conti
3044  1215   continue
3045       enddo   ! i
3046 cd      do i=1,nres
3047 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3048 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3049 cd      enddo
3050 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3051 ccc      eel_loc=eel_loc+eello_turn3
3052       return
3053       end
3054 C-----------------------------------------------------------------------------
3055       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3056 C Third- and fourth-order contributions from turns
3057       implicit real*8 (a-h,o-z)
3058       include 'DIMENSIONS'
3059       include 'DIMENSIONS.ZSCOPT'
3060       include 'COMMON.IOUNITS'
3061       include 'COMMON.GEO'
3062       include 'COMMON.VAR'
3063       include 'COMMON.LOCAL'
3064       include 'COMMON.CHAIN'
3065       include 'COMMON.DERIV'
3066       include 'COMMON.INTERACT'
3067       include 'COMMON.CONTACTS'
3068       include 'COMMON.TORSION'
3069       include 'COMMON.VECTORS'
3070       include 'COMMON.FFIELD'
3071       include 'COMMON.SHIELD'
3072       include 'COMMON.CONTROL'
3073       dimension ggg(3)
3074       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3075      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3076      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3077       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3078      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3079       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3080       if (j.eq.i+2) then
3081       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3082 C changes suggested by Ana to avoid out of bounds
3083 C     & .or.((i+5).gt.nres)
3084 C     & .or.((i-1).le.0)
3085 C end of changes suggested by Ana
3086      &    .or. itype(i+2).eq.ntyp1
3087      &    .or. itype(i+3).eq.ntyp1
3088 C     &    .or. itype(i+5).eq.ntyp1
3089 C     &    .or. itype(i).eq.ntyp1
3090 C     &    .or. itype(i-1).eq.ntyp1
3091      &    ) goto 179
3092
3093 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3094 C
3095 C               Third-order contributions
3096 C
3097 C                 (i+2)o----(i+3)
3098 C                      | |
3099 C                      | |
3100 C                 (i+1)o----i
3101 C
3102 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3103 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3104         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3105         call transpose2(auxmat(1,1),auxmat1(1,1))
3106         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3107         if (shield_mode.eq.0) then
3108         fac_shield(i)=1.0
3109         fac_shield(j)=1.0
3110 C        else
3111 C        fac_shield(i)=0.4
3112 C        fac_shield(j)=0.6
3113         endif
3114
3115         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3116      &  *fac_shield(i)*fac_shield(j)
3117         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3118      &  *fac_shield(i)*fac_shield(j)
3119
3120 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3121 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3122 cd     &    ' eello_turn3_num',4*eello_turn3_num
3123         if (calc_grad) then
3124 C Derivatives in shield mode
3125           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3126      &  (shield_mode.gt.0)) then
3127 C          print *,i,j
3128
3129           do ilist=1,ishield_list(i)
3130            iresshield=shield_list(ilist,i)
3131            do k=1,3
3132            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3133 C     &      *2.0
3134            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3135      &              rlocshield
3136      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3137             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3138      &      +rlocshield
3139            enddo
3140           enddo
3141           do ilist=1,ishield_list(j)
3142            iresshield=shield_list(ilist,j)
3143            do k=1,3
3144            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3145 C     &     *2.0
3146            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3147      &              rlocshield
3148      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3149            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3150      &             +rlocshield
3151
3152            enddo
3153           enddo
3154
3155           do k=1,3
3156             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3157      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3158             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3159      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3160             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3161      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3162             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3163      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3164            enddo
3165            endif
3166
3167 C Derivatives in gamma(i)
3168         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3169         call transpose2(auxmat2(1,1),pizda(1,1))
3170         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3171         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3172      &   *fac_shield(i)*fac_shield(j)
3173 C Derivatives in gamma(i+1)
3174         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3175         call transpose2(auxmat2(1,1),pizda(1,1))
3176         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3177         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3178      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3179      &   *fac_shield(i)*fac_shield(j)
3180
3181 C Cartesian derivatives
3182         do l=1,3
3183           a_temp(1,1)=aggi(l,1)
3184           a_temp(1,2)=aggi(l,2)
3185           a_temp(2,1)=aggi(l,3)
3186           a_temp(2,2)=aggi(l,4)
3187           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3188           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3189      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3190      &   *fac_shield(i)*fac_shield(j)
3191
3192           a_temp(1,1)=aggi1(l,1)
3193           a_temp(1,2)=aggi1(l,2)
3194           a_temp(2,1)=aggi1(l,3)
3195           a_temp(2,2)=aggi1(l,4)
3196           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3197           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3198      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3199      &   *fac_shield(i)*fac_shield(j)
3200
3201           a_temp(1,1)=aggj(l,1)
3202           a_temp(1,2)=aggj(l,2)
3203           a_temp(2,1)=aggj(l,3)
3204           a_temp(2,2)=aggj(l,4)
3205           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3206           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3207      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3208      &   *fac_shield(i)*fac_shield(j)
3209
3210           a_temp(1,1)=aggj1(l,1)
3211           a_temp(1,2)=aggj1(l,2)
3212           a_temp(2,1)=aggj1(l,3)
3213           a_temp(2,2)=aggj1(l,4)
3214           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3215           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3216      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3217      &   *fac_shield(i)*fac_shield(j)
3218
3219         enddo
3220         endif
3221   179 continue
3222       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3223       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3224 C changes suggested by Ana to avoid out of bounds
3225 C     & .or.((i+5).gt.nres)
3226 C     & .or.((i-1).le.0)
3227 C end of changes suggested by Ana
3228      &    .or. itype(i+3).eq.ntyp1
3229      &    .or. itype(i+4).eq.ntyp1
3230 C     &    .or. itype(i+5).eq.ntyp1
3231      &    .or. itype(i).eq.ntyp1
3232 C     &    .or. itype(i-1).eq.ntyp1
3233      &    ) goto 178
3234 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3235 C
3236 C               Fourth-order contributions
3237 C
3238 C                 (i+3)o----(i+4)
3239 C                     /  |
3240 C               (i+2)o   |
3241 C                     \  |
3242 C                 (i+1)o----i
3243 C
3244 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3245 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3246         iti1=itortyp(itype(i+1))
3247         iti2=itortyp(itype(i+2))
3248         iti3=itortyp(itype(i+3))
3249         call transpose2(EUg(1,1,i+1),e1t(1,1))
3250         call transpose2(Eug(1,1,i+2),e2t(1,1))
3251         call transpose2(Eug(1,1,i+3),e3t(1,1))
3252         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3253         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3254         s1=scalar2(b1(1,iti2),auxvec(1))
3255         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3256         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3257         s2=scalar2(b1(1,iti1),auxvec(1))
3258         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3259         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3260         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3261         if (shield_mode.eq.0) then
3262         fac_shield(i)=1.0
3263         fac_shield(j)=1.0
3264 C        else
3265 C        fac_shield(i)=0.4
3266 C        fac_shield(j)=0.6
3267         endif
3268
3269         eello_turn4=eello_turn4-(s1+s2+s3)
3270      &  *fac_shield(i)*fac_shield(j)
3271         eello_t4=-(s1+s2+s3)
3272      &  *fac_shield(i)*fac_shield(j)
3273
3274 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3275 cd     &    ' eello_turn4_num',8*eello_turn4_num
3276 C Derivatives in gamma(i)
3277         if (calc_grad) then
3278           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3279      &  (shield_mode.gt.0)) then
3280 C          print *,i,j
3281
3282           do ilist=1,ishield_list(i)
3283            iresshield=shield_list(ilist,i)
3284            do k=1,3
3285            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3286 C     &      *2.0
3287            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3288      &              rlocshield
3289      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3290             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3291      &      +rlocshield
3292            enddo
3293           enddo
3294           do ilist=1,ishield_list(j)
3295            iresshield=shield_list(ilist,j)
3296            do k=1,3
3297            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3298 C     &     *2.0
3299            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3300      &              rlocshield
3301      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3302            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3303      &             +rlocshield
3304
3305            enddo
3306           enddo
3307
3308           do k=1,3
3309             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3310      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3311             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3312      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3313             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3314      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3315             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3316      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3317            enddo
3318            endif
3319         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3320         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3321         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3322         s1=scalar2(b1(1,iti2),auxvec(1))
3323         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3324         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3325         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3326      &  *fac_shield(i)*fac_shield(j)
3327
3328 C Derivatives in gamma(i+1)
3329         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3330         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3331         s2=scalar2(b1(1,iti1),auxvec(1))
3332         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3333         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3334         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3335         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3336      &  *fac_shield(i)*fac_shield(j)
3337
3338 C Derivatives in gamma(i+2)
3339         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3340         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3341         s1=scalar2(b1(1,iti2),auxvec(1))
3342         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3343         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3344         s2=scalar2(b1(1,iti1),auxvec(1))
3345         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3346         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3347         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3348         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3349      &  *fac_shield(i)*fac_shield(j)
3350
3351 C Cartesian derivatives
3352
3353 C Derivatives of this turn contributions in DC(i+2)
3354         if (j.lt.nres-1) then
3355           do l=1,3
3356             a_temp(1,1)=agg(l,1)
3357             a_temp(1,2)=agg(l,2)
3358             a_temp(2,1)=agg(l,3)
3359             a_temp(2,2)=agg(l,4)
3360             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3361             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3362             s1=scalar2(b1(1,iti2),auxvec(1))
3363             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3364             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3365             s2=scalar2(b1(1,iti1),auxvec(1))
3366             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3367             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3368             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3369             ggg(l)=-(s1+s2+s3)
3370             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3371      &  *fac_shield(i)*fac_shield(j)
3372
3373           enddo
3374         endif
3375 C Remaining derivatives of this turn contribution
3376         do l=1,3
3377           a_temp(1,1)=aggi(l,1)
3378           a_temp(1,2)=aggi(l,2)
3379           a_temp(2,1)=aggi(l,3)
3380           a_temp(2,2)=aggi(l,4)
3381           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3382           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3383           s1=scalar2(b1(1,iti2),auxvec(1))
3384           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3385           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3386           s2=scalar2(b1(1,iti1),auxvec(1))
3387           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3388           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3389           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3390           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3391      &  *fac_shield(i)*fac_shield(j)
3392
3393           a_temp(1,1)=aggi1(l,1)
3394           a_temp(1,2)=aggi1(l,2)
3395           a_temp(2,1)=aggi1(l,3)
3396           a_temp(2,2)=aggi1(l,4)
3397           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3398           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3399           s1=scalar2(b1(1,iti2),auxvec(1))
3400           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3401           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3402           s2=scalar2(b1(1,iti1),auxvec(1))
3403           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3404           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3405           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3406           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3407      &  *fac_shield(i)*fac_shield(j)
3408
3409           a_temp(1,1)=aggj(l,1)
3410           a_temp(1,2)=aggj(l,2)
3411           a_temp(2,1)=aggj(l,3)
3412           a_temp(2,2)=aggj(l,4)
3413           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3414           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3415           s1=scalar2(b1(1,iti2),auxvec(1))
3416           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3417           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3418           s2=scalar2(b1(1,iti1),auxvec(1))
3419           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3420           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3421           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3422           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3423      &  *fac_shield(i)*fac_shield(j)
3424
3425           a_temp(1,1)=aggj1(l,1)
3426           a_temp(1,2)=aggj1(l,2)
3427           a_temp(2,1)=aggj1(l,3)
3428           a_temp(2,2)=aggj1(l,4)
3429           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3430           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3431           s1=scalar2(b1(1,iti2),auxvec(1))
3432           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3433           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3434           s2=scalar2(b1(1,iti1),auxvec(1))
3435           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3436           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3437           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3438           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3439      &  *fac_shield(i)*fac_shield(j)
3440
3441         enddo
3442         endif
3443  178  continue
3444       endif
3445       return
3446       end
3447 C-----------------------------------------------------------------------------
3448       subroutine vecpr(u,v,w)
3449       implicit real*8(a-h,o-z)
3450       dimension u(3),v(3),w(3)
3451       w(1)=u(2)*v(3)-u(3)*v(2)
3452       w(2)=-u(1)*v(3)+u(3)*v(1)
3453       w(3)=u(1)*v(2)-u(2)*v(1)
3454       return
3455       end
3456 C-----------------------------------------------------------------------------
3457       subroutine unormderiv(u,ugrad,unorm,ungrad)
3458 C This subroutine computes the derivatives of a normalized vector u, given
3459 C the derivatives computed without normalization conditions, ugrad. Returns
3460 C ungrad.
3461       implicit none
3462       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3463       double precision vec(3)
3464       double precision scalar
3465       integer i,j
3466 c      write (2,*) 'ugrad',ugrad
3467 c      write (2,*) 'u',u
3468       do i=1,3
3469         vec(i)=scalar(ugrad(1,i),u(1))
3470       enddo
3471 c      write (2,*) 'vec',vec
3472       do i=1,3
3473         do j=1,3
3474           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3475         enddo
3476       enddo
3477 c      write (2,*) 'ungrad',ungrad
3478       return
3479       end
3480 C-----------------------------------------------------------------------------
3481       subroutine escp(evdw2,evdw2_14)
3482 C
3483 C This subroutine calculates the excluded-volume interaction energy between
3484 C peptide-group centers and side chains and its gradient in virtual-bond and
3485 C side-chain vectors.
3486 C
3487       implicit real*8 (a-h,o-z)
3488       include 'DIMENSIONS'
3489       include 'DIMENSIONS.ZSCOPT'
3490       include 'COMMON.GEO'
3491       include 'COMMON.VAR'
3492       include 'COMMON.LOCAL'
3493       include 'COMMON.CHAIN'
3494       include 'COMMON.DERIV'
3495       include 'COMMON.INTERACT'
3496       include 'COMMON.FFIELD'
3497       include 'COMMON.IOUNITS'
3498       dimension ggg(3)
3499       evdw2=0.0D0
3500       evdw2_14=0.0d0
3501 cd    print '(a)','Enter ESCP'
3502 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3503 c     &  ' scal14',scal14
3504       do i=iatscp_s,iatscp_e
3505         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3506         iteli=itel(i)
3507 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3508 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3509         if (iteli.eq.0) goto 1225
3510         xi=0.5D0*(c(1,i)+c(1,i+1))
3511         yi=0.5D0*(c(2,i)+c(2,i+1))
3512         zi=0.5D0*(c(3,i)+c(3,i+1))
3513 C Returning the ith atom to box
3514           xi=mod(xi,boxxsize)
3515           if (xi.lt.0) xi=xi+boxxsize
3516           yi=mod(yi,boxysize)
3517           if (yi.lt.0) yi=yi+boxysize
3518           zi=mod(zi,boxzsize)
3519           if (zi.lt.0) zi=zi+boxzsize
3520         do iint=1,nscp_gr(i)
3521
3522         do j=iscpstart(i,iint),iscpend(i,iint)
3523           itypj=iabs(itype(j))
3524           if (itypj.eq.ntyp1) cycle
3525 C Uncomment following three lines for SC-p interactions
3526 c         xj=c(1,nres+j)-xi
3527 c         yj=c(2,nres+j)-yi
3528 c         zj=c(3,nres+j)-zi
3529 C Uncomment following three lines for Ca-p interactions
3530           xj=c(1,j)
3531           yj=c(2,j)
3532           zj=c(3,j)
3533 C returning the jth atom to box
3534           xj=mod(xj,boxxsize)
3535           if (xj.lt.0) xj=xj+boxxsize
3536           yj=mod(yj,boxysize)
3537           if (yj.lt.0) yj=yj+boxysize
3538           zj=mod(zj,boxzsize)
3539           if (zj.lt.0) zj=zj+boxzsize
3540       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3541       xj_safe=xj
3542       yj_safe=yj
3543       zj_safe=zj
3544       subchap=0
3545 C Finding the closest jth atom
3546       do xshift=-1,1
3547       do yshift=-1,1
3548       do zshift=-1,1
3549           xj=xj_safe+xshift*boxxsize
3550           yj=yj_safe+yshift*boxysize
3551           zj=zj_safe+zshift*boxzsize
3552           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3553           if(dist_temp.lt.dist_init) then
3554             dist_init=dist_temp
3555             xj_temp=xj
3556             yj_temp=yj
3557             zj_temp=zj
3558             subchap=1
3559           endif
3560        enddo
3561        enddo
3562        enddo
3563        if (subchap.eq.1) then
3564           xj=xj_temp-xi
3565           yj=yj_temp-yi
3566           zj=zj_temp-zi
3567        else
3568           xj=xj_safe-xi
3569           yj=yj_safe-yi
3570           zj=zj_safe-zi
3571        endif
3572           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3573 C sss is scaling function for smoothing the cutoff gradient otherwise
3574 C the gradient would not be continuouse
3575           sss=sscale(1.0d0/(dsqrt(rrij)))
3576           if (sss.le.0.0d0) cycle
3577           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3578           fac=rrij**expon2
3579           e1=fac*fac*aad(itypj,iteli)
3580           e2=fac*bad(itypj,iteli)
3581           if (iabs(j-i) .le. 2) then
3582             e1=scal14*e1
3583             e2=scal14*e2
3584             evdw2_14=evdw2_14+(e1+e2)*sss
3585           endif
3586           evdwij=e1+e2
3587 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3588 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3589 c     &       bad(itypj,iteli)
3590           evdw2=evdw2+evdwij*sss
3591           if (calc_grad) then
3592 C
3593 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3594 C
3595           fac=-(evdwij+e1)*rrij*sss
3596           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3597           ggg(1)=xj*fac
3598           ggg(2)=yj*fac
3599           ggg(3)=zj*fac
3600           if (j.lt.i) then
3601 cd          write (iout,*) 'j<i'
3602 C Uncomment following three lines for SC-p interactions
3603 c           do k=1,3
3604 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3605 c           enddo
3606           else
3607 cd          write (iout,*) 'j>i'
3608             do k=1,3
3609               ggg(k)=-ggg(k)
3610 C Uncomment following line for SC-p interactions
3611 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3612             enddo
3613           endif
3614           do k=1,3
3615             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3616           enddo
3617           kstart=min0(i+1,j)
3618           kend=max0(i-1,j-1)
3619 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3620 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3621           do k=kstart,kend
3622             do l=1,3
3623               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3624             enddo
3625           enddo
3626           endif
3627         enddo
3628         enddo ! iint
3629  1225   continue
3630       enddo ! i
3631       do i=1,nct
3632         do j=1,3
3633           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3634           gradx_scp(j,i)=expon*gradx_scp(j,i)
3635         enddo
3636       enddo
3637 C******************************************************************************
3638 C
3639 C                              N O T E !!!
3640 C
3641 C To save time the factor EXPON has been extracted from ALL components
3642 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3643 C use!
3644 C
3645 C******************************************************************************
3646       return
3647       end
3648 C--------------------------------------------------------------------------
3649       subroutine edis(ehpb)
3650 C
3651 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3652 C
3653       implicit real*8 (a-h,o-z)
3654       include 'DIMENSIONS'
3655       include 'DIMENSIONS.ZSCOPT'
3656       include 'COMMON.SBRIDGE'
3657       include 'COMMON.CHAIN'
3658       include 'COMMON.DERIV'
3659       include 'COMMON.VAR'
3660       include 'COMMON.INTERACT'
3661       include 'COMMON.CONTROL'
3662       include 'COMMON.IOUNITS'
3663       dimension ggg(3)
3664       ehpb=0.0D0
3665 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3666 cd    print *,'link_start=',link_start,' link_end=',link_end
3667 C      write(iout,*) link_end, "link_end"
3668       if (link_end.eq.0) return
3669       do i=link_start,link_end
3670 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3671 C CA-CA distance used in regularization of structure.
3672         ii=ihpb(i)
3673         jj=jhpb(i)
3674 C iii and jjj point to the residues for which the distance is assigned.
3675         if (ii.gt.nres) then
3676           iii=ii-nres
3677           jjj=jj-nres
3678         else
3679           iii=ii
3680           jjj=jj
3681         endif
3682 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3683 C    distance and angle dependent SS bond potential.
3684 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3685 C     & iabs(itype(jjj)).eq.1) then
3686 C       write(iout,*) constr_dist,"const"
3687        if (.not.dyn_ss .and. i.le.nss) then
3688          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3689      & iabs(itype(jjj)).eq.1) then
3690           call ssbond_ene(iii,jjj,eij)
3691           ehpb=ehpb+2*eij
3692            endif !ii.gt.neres
3693         else if (ii.gt.nres .and. jj.gt.nres) then
3694 c Restraints from contact prediction
3695           dd=dist(ii,jj)
3696           if (constr_dist.eq.11) then
3697 C            ehpb=ehpb+fordepth(i)**4.0d0
3698 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3699             ehpb=ehpb+fordepth(i)**4.0d0
3700      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3701             fac=fordepth(i)**4.0d0
3702      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3703 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3704 C     &    ehpb,fordepth(i),dd
3705 C            write(iout,*) ehpb,"atu?"
3706 C            ehpb,"tu?"
3707 C            fac=fordepth(i)**4.0d0
3708 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3709            else
3710           if (dhpb1(i).gt.0.0d0) then
3711             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3712             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3713 c            write (iout,*) "beta nmr",
3714 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3715           else
3716             dd=dist(ii,jj)
3717             rdis=dd-dhpb(i)
3718 C Get the force constant corresponding to this distance.
3719             waga=forcon(i)
3720 C Calculate the contribution to energy.
3721             ehpb=ehpb+waga*rdis*rdis
3722 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3723 C
3724 C Evaluate gradient.
3725 C
3726             fac=waga*rdis/dd
3727           endif !end dhpb1(i).gt.0
3728           endif !end const_dist=11
3729           do j=1,3
3730             ggg(j)=fac*(c(j,jj)-c(j,ii))
3731           enddo
3732           do j=1,3
3733             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3734             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3735           enddo
3736           do k=1,3
3737             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3738             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3739           enddo
3740         else !ii.gt.nres
3741 C          write(iout,*) "before"
3742           dd=dist(ii,jj)
3743 C          write(iout,*) "after",dd
3744           if (constr_dist.eq.11) then
3745             ehpb=ehpb+fordepth(i)**4.0d0
3746      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3747             fac=fordepth(i)**4.0d0
3748      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3749 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3750 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3751 C            print *,ehpb,"tu?"
3752 C            write(iout,*) ehpb,"btu?",
3753 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3754 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3755 C     &    ehpb,fordepth(i),dd
3756            else
3757           if (dhpb1(i).gt.0.0d0) then
3758             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3759             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3760 c            write (iout,*) "alph nmr",
3761 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3762           else
3763             rdis=dd-dhpb(i)
3764 C Get the force constant corresponding to this distance.
3765             waga=forcon(i)
3766 C Calculate the contribution to energy.
3767             ehpb=ehpb+waga*rdis*rdis
3768 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3769 C
3770 C Evaluate gradient.
3771 C
3772             fac=waga*rdis/dd
3773           endif
3774           endif
3775
3776         do j=1,3
3777           ggg(j)=fac*(c(j,jj)-c(j,ii))
3778         enddo
3779 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3780 C If this is a SC-SC distance, we need to calculate the contributions to the
3781 C Cartesian gradient in the SC vectors (ghpbx).
3782         if (iii.lt.ii) then
3783           do j=1,3
3784             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3785             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3786           enddo
3787         endif
3788         do j=iii,jjj-1
3789           do k=1,3
3790             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3791           enddo
3792         enddo
3793         endif
3794       enddo
3795       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3796       return
3797       end
3798 C--------------------------------------------------------------------------
3799       subroutine ssbond_ene(i,j,eij)
3800 C
3801 C Calculate the distance and angle dependent SS-bond potential energy
3802 C using a free-energy function derived based on RHF/6-31G** ab initio
3803 C calculations of diethyl disulfide.
3804 C
3805 C A. Liwo and U. Kozlowska, 11/24/03
3806 C
3807       implicit real*8 (a-h,o-z)
3808       include 'DIMENSIONS'
3809       include 'DIMENSIONS.ZSCOPT'
3810       include 'COMMON.SBRIDGE'
3811       include 'COMMON.CHAIN'
3812       include 'COMMON.DERIV'
3813       include 'COMMON.LOCAL'
3814       include 'COMMON.INTERACT'
3815       include 'COMMON.VAR'
3816       include 'COMMON.IOUNITS'
3817       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3818       itypi=iabs(itype(i))
3819       xi=c(1,nres+i)
3820       yi=c(2,nres+i)
3821       zi=c(3,nres+i)
3822       dxi=dc_norm(1,nres+i)
3823       dyi=dc_norm(2,nres+i)
3824       dzi=dc_norm(3,nres+i)
3825       dsci_inv=dsc_inv(itypi)
3826       itypj=iabs(itype(j))
3827       dscj_inv=dsc_inv(itypj)
3828       xj=c(1,nres+j)-xi
3829       yj=c(2,nres+j)-yi
3830       zj=c(3,nres+j)-zi
3831       dxj=dc_norm(1,nres+j)
3832       dyj=dc_norm(2,nres+j)
3833       dzj=dc_norm(3,nres+j)
3834       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3835       rij=dsqrt(rrij)
3836       erij(1)=xj*rij
3837       erij(2)=yj*rij
3838       erij(3)=zj*rij
3839       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3840       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3841       om12=dxi*dxj+dyi*dyj+dzi*dzj
3842       do k=1,3
3843         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3844         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3845       enddo
3846       rij=1.0d0/rij
3847       deltad=rij-d0cm
3848       deltat1=1.0d0-om1
3849       deltat2=1.0d0+om2
3850       deltat12=om2-om1+2.0d0
3851       cosphi=om12-om1*om2
3852       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3853      &  +akct*deltad*deltat12
3854      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3855 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3856 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3857 c     &  " deltat12",deltat12," eij",eij
3858       ed=2*akcm*deltad+akct*deltat12
3859       pom1=akct*deltad
3860       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3861       eom1=-2*akth*deltat1-pom1-om2*pom2
3862       eom2= 2*akth*deltat2+pom1-om1*pom2
3863       eom12=pom2
3864       do k=1,3
3865         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3866       enddo
3867       do k=1,3
3868         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3869      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3870         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3871      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3872       enddo
3873 C
3874 C Calculate the components of the gradient in DC and X
3875 C
3876       do k=i,j-1
3877         do l=1,3
3878           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3879         enddo
3880       enddo
3881       return
3882       end
3883 C--------------------------------------------------------------------------
3884       subroutine ebond(estr)
3885 c
3886 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3887 c
3888       implicit real*8 (a-h,o-z)
3889       include 'DIMENSIONS'
3890       include 'DIMENSIONS.ZSCOPT'
3891       include 'COMMON.LOCAL'
3892       include 'COMMON.GEO'
3893       include 'COMMON.INTERACT'
3894       include 'COMMON.DERIV'
3895       include 'COMMON.VAR'
3896       include 'COMMON.CHAIN'
3897       include 'COMMON.IOUNITS'
3898       include 'COMMON.NAMES'
3899       include 'COMMON.FFIELD'
3900       include 'COMMON.CONTROL'
3901       logical energy_dec /.false./
3902       double precision u(3),ud(3)
3903       estr=0.0d0
3904       estr1=0.0d0
3905 c      write (iout,*) "distchainmax",distchainmax
3906       do i=nnt+1,nct
3907         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3908 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3909 C          do j=1,3
3910 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3911 C     &      *dc(j,i-1)/vbld(i)
3912 C          enddo
3913 C          if (energy_dec) write(iout,*)
3914 C     &       "estr1",i,vbld(i),distchainmax,
3915 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3916 C        else
3917          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3918         diff = vbld(i)-vbldpDUM
3919 C         write(iout,*) i,diff
3920          else
3921           diff = vbld(i)-vbldp0
3922 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3923          endif
3924           estr=estr+diff*diff
3925           do j=1,3
3926             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3927           enddo
3928 C        endif
3929 C        write (iout,'(a7,i5,4f7.3)')
3930 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3931       enddo
3932       estr=0.5d0*AKP*estr+estr1
3933 c
3934 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3935 c
3936       do i=nnt,nct
3937         iti=iabs(itype(i))
3938         if (iti.ne.10 .and. iti.ne.ntyp1) then
3939           nbi=nbondterm(iti)
3940           if (nbi.eq.1) then
3941             diff=vbld(i+nres)-vbldsc0(1,iti)
3942 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3943 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3944             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3945             do j=1,3
3946               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3947             enddo
3948           else
3949             do j=1,nbi
3950               diff=vbld(i+nres)-vbldsc0(j,iti)
3951               ud(j)=aksc(j,iti)*diff
3952               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3953             enddo
3954             uprod=u(1)
3955             do j=2,nbi
3956               uprod=uprod*u(j)
3957             enddo
3958             usum=0.0d0
3959             usumsqder=0.0d0
3960             do j=1,nbi
3961               uprod1=1.0d0
3962               uprod2=1.0d0
3963               do k=1,nbi
3964                 if (k.ne.j) then
3965                   uprod1=uprod1*u(k)
3966                   uprod2=uprod2*u(k)*u(k)
3967                 endif
3968               enddo
3969               usum=usum+uprod1
3970               usumsqder=usumsqder+ud(j)*uprod2
3971             enddo
3972 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3973 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3974             estr=estr+uprod/usum
3975             do j=1,3
3976              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3977             enddo
3978           endif
3979         endif
3980       enddo
3981       return
3982       end
3983 #ifdef CRYST_THETA
3984 C--------------------------------------------------------------------------
3985       subroutine ebend(etheta,ethetacnstr)
3986 C
3987 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3988 C angles gamma and its derivatives in consecutive thetas and gammas.
3989 C
3990       implicit real*8 (a-h,o-z)
3991       include 'DIMENSIONS'
3992       include 'DIMENSIONS.ZSCOPT'
3993       include 'COMMON.LOCAL'
3994       include 'COMMON.GEO'
3995       include 'COMMON.INTERACT'
3996       include 'COMMON.DERIV'
3997       include 'COMMON.VAR'
3998       include 'COMMON.CHAIN'
3999       include 'COMMON.IOUNITS'
4000       include 'COMMON.NAMES'
4001       include 'COMMON.FFIELD'
4002       include 'COMMON.TORCNSTR'
4003       common /calcthet/ term1,term2,termm,diffak,ratak,
4004      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4005      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4006       double precision y(2),z(2)
4007       delta=0.02d0*pi
4008 c      time11=dexp(-2*time)
4009 c      time12=1.0d0
4010       etheta=0.0D0
4011 c      write (iout,*) "nres",nres
4012 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4013 c      write (iout,*) ithet_start,ithet_end
4014       do i=ithet_start,ithet_end
4015 C        if (itype(i-1).eq.ntyp1) cycle
4016         if (i.le.2) cycle
4017         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4018      &  .or.itype(i).eq.ntyp1) cycle
4019 C Zero the energy function and its derivative at 0 or pi.
4020         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4021         it=itype(i-1)
4022         ichir1=isign(1,itype(i-2))
4023         ichir2=isign(1,itype(i))
4024          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4025          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4026          if (itype(i-1).eq.10) then
4027           itype1=isign(10,itype(i-2))
4028           ichir11=isign(1,itype(i-2))
4029           ichir12=isign(1,itype(i-2))
4030           itype2=isign(10,itype(i))
4031           ichir21=isign(1,itype(i))
4032           ichir22=isign(1,itype(i))
4033          endif
4034          if (i.eq.3) then
4035           y(1)=0.0D0
4036           y(2)=0.0D0
4037           else
4038
4039         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4040 #ifdef OSF
4041           phii=phi(i)
4042 c          icrc=0
4043 c          call proc_proc(phii,icrc)
4044           if (icrc.eq.1) phii=150.0
4045 #else
4046           phii=phi(i)
4047 #endif
4048           y(1)=dcos(phii)
4049           y(2)=dsin(phii)
4050         else
4051           y(1)=0.0D0
4052           y(2)=0.0D0
4053         endif
4054         endif
4055         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4056 #ifdef OSF
4057           phii1=phi(i+1)
4058 c          icrc=0
4059 c          call proc_proc(phii1,icrc)
4060           if (icrc.eq.1) phii1=150.0
4061           phii1=pinorm(phii1)
4062           z(1)=cos(phii1)
4063 #else
4064           phii1=phi(i+1)
4065           z(1)=dcos(phii1)
4066 #endif
4067           z(2)=dsin(phii1)
4068         else
4069           z(1)=0.0D0
4070           z(2)=0.0D0
4071         endif
4072 C Calculate the "mean" value of theta from the part of the distribution
4073 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4074 C In following comments this theta will be referred to as t_c.
4075         thet_pred_mean=0.0d0
4076         do k=1,2
4077             athetk=athet(k,it,ichir1,ichir2)
4078             bthetk=bthet(k,it,ichir1,ichir2)
4079           if (it.eq.10) then
4080              athetk=athet(k,itype1,ichir11,ichir12)
4081              bthetk=bthet(k,itype2,ichir21,ichir22)
4082           endif
4083           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4084         enddo
4085 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4086         dthett=thet_pred_mean*ssd
4087         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4088 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4089 C Derivatives of the "mean" values in gamma1 and gamma2.
4090         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4091      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4092          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4093      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4094          if (it.eq.10) then
4095       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4096      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4097         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4098      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4099          endif
4100         if (theta(i).gt.pi-delta) then
4101           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4102      &         E_tc0)
4103           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4104           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4105           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4106      &        E_theta)
4107           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4108      &        E_tc)
4109         else if (theta(i).lt.delta) then
4110           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4111           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4112           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4113      &        E_theta)
4114           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4115           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4116      &        E_tc)
4117         else
4118           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4119      &        E_theta,E_tc)
4120         endif
4121         etheta=etheta+ethetai
4122 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4123 c     &      'ebend',i,ethetai,theta(i),itype(i)
4124 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4125 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4126         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4127         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4128         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4129 c 1215   continue
4130       enddo
4131       ethetacnstr=0.0d0
4132 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4133       do i=1,ntheta_constr
4134         itheta=itheta_constr(i)
4135         thetiii=theta(itheta)
4136         difi=pinorm(thetiii-theta_constr0(i))
4137         if (difi.gt.theta_drange(i)) then
4138           difi=difi-theta_drange(i)
4139           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4140           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4141      &    +for_thet_constr(i)*difi**3
4142         else if (difi.lt.-drange(i)) then
4143           difi=difi+drange(i)
4144           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4145           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4146      &    +for_thet_constr(i)*difi**3
4147         else
4148           difi=0.0
4149         endif
4150 C       if (energy_dec) then
4151 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4152 C     &    i,itheta,rad2deg*thetiii,
4153 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4154 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4155 C     &    gloc(itheta+nphi-2,icg)
4156 C        endif
4157       enddo
4158 C Ufff.... We've done all this!!!
4159       return
4160       end
4161 C---------------------------------------------------------------------------
4162       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4163      &     E_tc)
4164       implicit real*8 (a-h,o-z)
4165       include 'DIMENSIONS'
4166       include 'COMMON.LOCAL'
4167       include 'COMMON.IOUNITS'
4168       common /calcthet/ term1,term2,termm,diffak,ratak,
4169      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4170      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4171 C Calculate the contributions to both Gaussian lobes.
4172 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4173 C The "polynomial part" of the "standard deviation" of this part of
4174 C the distribution.
4175         sig=polthet(3,it)
4176         do j=2,0,-1
4177           sig=sig*thet_pred_mean+polthet(j,it)
4178         enddo
4179 C Derivative of the "interior part" of the "standard deviation of the"
4180 C gamma-dependent Gaussian lobe in t_c.
4181         sigtc=3*polthet(3,it)
4182         do j=2,1,-1
4183           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4184         enddo
4185         sigtc=sig*sigtc
4186 C Set the parameters of both Gaussian lobes of the distribution.
4187 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4188         fac=sig*sig+sigc0(it)
4189         sigcsq=fac+fac
4190         sigc=1.0D0/sigcsq
4191 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4192         sigsqtc=-4.0D0*sigcsq*sigtc
4193 c       print *,i,sig,sigtc,sigsqtc
4194 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4195         sigtc=-sigtc/(fac*fac)
4196 C Following variable is sigma(t_c)**(-2)
4197         sigcsq=sigcsq*sigcsq
4198         sig0i=sig0(it)
4199         sig0inv=1.0D0/sig0i**2
4200         delthec=thetai-thet_pred_mean
4201         delthe0=thetai-theta0i
4202         term1=-0.5D0*sigcsq*delthec*delthec
4203         term2=-0.5D0*sig0inv*delthe0*delthe0
4204 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4205 C NaNs in taking the logarithm. We extract the largest exponent which is added
4206 C to the energy (this being the log of the distribution) at the end of energy
4207 C term evaluation for this virtual-bond angle.
4208         if (term1.gt.term2) then
4209           termm=term1
4210           term2=dexp(term2-termm)
4211           term1=1.0d0
4212         else
4213           termm=term2
4214           term1=dexp(term1-termm)
4215           term2=1.0d0
4216         endif
4217 C The ratio between the gamma-independent and gamma-dependent lobes of
4218 C the distribution is a Gaussian function of thet_pred_mean too.
4219         diffak=gthet(2,it)-thet_pred_mean
4220         ratak=diffak/gthet(3,it)**2
4221         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4222 C Let's differentiate it in thet_pred_mean NOW.
4223         aktc=ak*ratak
4224 C Now put together the distribution terms to make complete distribution.
4225         termexp=term1+ak*term2
4226         termpre=sigc+ak*sig0i
4227 C Contribution of the bending energy from this theta is just the -log of
4228 C the sum of the contributions from the two lobes and the pre-exponential
4229 C factor. Simple enough, isn't it?
4230         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4231 C NOW the derivatives!!!
4232 C 6/6/97 Take into account the deformation.
4233         E_theta=(delthec*sigcsq*term1
4234      &       +ak*delthe0*sig0inv*term2)/termexp
4235         E_tc=((sigtc+aktc*sig0i)/termpre
4236      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4237      &       aktc*term2)/termexp)
4238       return
4239       end
4240 c-----------------------------------------------------------------------------
4241       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4242       implicit real*8 (a-h,o-z)
4243       include 'DIMENSIONS'
4244       include 'COMMON.LOCAL'
4245       include 'COMMON.IOUNITS'
4246       common /calcthet/ term1,term2,termm,diffak,ratak,
4247      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4248      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4249       delthec=thetai-thet_pred_mean
4250       delthe0=thetai-theta0i
4251 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4252       t3 = thetai-thet_pred_mean
4253       t6 = t3**2
4254       t9 = term1
4255       t12 = t3*sigcsq
4256       t14 = t12+t6*sigsqtc
4257       t16 = 1.0d0
4258       t21 = thetai-theta0i
4259       t23 = t21**2
4260       t26 = term2
4261       t27 = t21*t26
4262       t32 = termexp
4263       t40 = t32**2
4264       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4265      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4266      & *(-t12*t9-ak*sig0inv*t27)
4267       return
4268       end
4269 #else
4270 C--------------------------------------------------------------------------
4271       subroutine ebend(etheta,ethetacnstr)
4272 C
4273 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4274 C angles gamma and its derivatives in consecutive thetas and gammas.
4275 C ab initio-derived potentials from
4276 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4277 C
4278       implicit real*8 (a-h,o-z)
4279       include 'DIMENSIONS'
4280       include 'DIMENSIONS.ZSCOPT'
4281       include 'COMMON.LOCAL'
4282       include 'COMMON.GEO'
4283       include 'COMMON.INTERACT'
4284       include 'COMMON.DERIV'
4285       include 'COMMON.VAR'
4286       include 'COMMON.CHAIN'
4287       include 'COMMON.IOUNITS'
4288       include 'COMMON.NAMES'
4289       include 'COMMON.FFIELD'
4290       include 'COMMON.CONTROL'
4291       include 'COMMON.TORCNSTR'
4292       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4293      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4294      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4295      & sinph1ph2(maxdouble,maxdouble)
4296       logical lprn /.false./, lprn1 /.false./
4297       etheta=0.0D0
4298 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4299       do i=ithet_start,ithet_end
4300 C         if (i.eq.2) cycle
4301 C        if (itype(i-1).eq.ntyp1) cycle
4302         if (i.le.2) cycle
4303         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4304      &  .or.itype(i).eq.ntyp1) cycle
4305         if (iabs(itype(i+1)).eq.20) iblock=2
4306         if (iabs(itype(i+1)).ne.20) iblock=1
4307         dethetai=0.0d0
4308         dephii=0.0d0
4309         dephii1=0.0d0
4310         theti2=0.5d0*theta(i)
4311         ityp2=ithetyp((itype(i-1)))
4312         do k=1,nntheterm
4313           coskt(k)=dcos(k*theti2)
4314           sinkt(k)=dsin(k*theti2)
4315         enddo
4316         if (i.eq.3) then
4317           phii=0.0d0
4318           ityp1=nthetyp+1
4319           do k=1,nsingle
4320             cosph1(k)=0.0d0
4321             sinph1(k)=0.0d0
4322           enddo
4323         else
4324         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4325 #ifdef OSF
4326           phii=phi(i)
4327           if (phii.ne.phii) phii=150.0
4328 #else
4329           phii=phi(i)
4330 #endif
4331           ityp1=ithetyp((itype(i-2)))
4332           do k=1,nsingle
4333             cosph1(k)=dcos(k*phii)
4334             sinph1(k)=dsin(k*phii)
4335           enddo
4336         else
4337           phii=0.0d0
4338 c          ityp1=nthetyp+1
4339           do k=1,nsingle
4340             ityp1=ithetyp((itype(i-2)))
4341             cosph1(k)=0.0d0
4342             sinph1(k)=0.0d0
4343           enddo
4344         endif
4345         endif
4346         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4347 #ifdef OSF
4348           phii1=phi(i+1)
4349           if (phii1.ne.phii1) phii1=150.0
4350           phii1=pinorm(phii1)
4351 #else
4352           phii1=phi(i+1)
4353 #endif
4354           ityp3=ithetyp((itype(i)))
4355           do k=1,nsingle
4356             cosph2(k)=dcos(k*phii1)
4357             sinph2(k)=dsin(k*phii1)
4358           enddo
4359         else
4360           phii1=0.0d0
4361 c          ityp3=nthetyp+1
4362           ityp3=ithetyp((itype(i)))
4363           do k=1,nsingle
4364             cosph2(k)=0.0d0
4365             sinph2(k)=0.0d0
4366           enddo
4367         endif
4368 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4369 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4370 c        call flush(iout)
4371         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4372         do k=1,ndouble
4373           do l=1,k-1
4374             ccl=cosph1(l)*cosph2(k-l)
4375             ssl=sinph1(l)*sinph2(k-l)
4376             scl=sinph1(l)*cosph2(k-l)
4377             csl=cosph1(l)*sinph2(k-l)
4378             cosph1ph2(l,k)=ccl-ssl
4379             cosph1ph2(k,l)=ccl+ssl
4380             sinph1ph2(l,k)=scl+csl
4381             sinph1ph2(k,l)=scl-csl
4382           enddo
4383         enddo
4384         if (lprn) then
4385         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4386      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4387         write (iout,*) "coskt and sinkt"
4388         do k=1,nntheterm
4389           write (iout,*) k,coskt(k),sinkt(k)
4390         enddo
4391         endif
4392         do k=1,ntheterm
4393           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4394           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4395      &      *coskt(k)
4396           if (lprn)
4397      &    write (iout,*) "k",k,"
4398      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4399      &     " ethetai",ethetai
4400         enddo
4401         if (lprn) then
4402         write (iout,*) "cosph and sinph"
4403         do k=1,nsingle
4404           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4405         enddo
4406         write (iout,*) "cosph1ph2 and sinph2ph2"
4407         do k=2,ndouble
4408           do l=1,k-1
4409             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4410      &         sinph1ph2(l,k),sinph1ph2(k,l)
4411           enddo
4412         enddo
4413         write(iout,*) "ethetai",ethetai
4414         endif
4415         do m=1,ntheterm2
4416           do k=1,nsingle
4417             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4418      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4419      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4420      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4421             ethetai=ethetai+sinkt(m)*aux
4422             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4423             dephii=dephii+k*sinkt(m)*(
4424      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4425      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4426             dephii1=dephii1+k*sinkt(m)*(
4427      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4428      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4429             if (lprn)
4430      &      write (iout,*) "m",m," k",k," bbthet",
4431      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4432      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4433      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4434      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4435           enddo
4436         enddo
4437         if (lprn)
4438      &  write(iout,*) "ethetai",ethetai
4439         do m=1,ntheterm3
4440           do k=2,ndouble
4441             do l=1,k-1
4442               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4443      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4444      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4445      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4446               ethetai=ethetai+sinkt(m)*aux
4447               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4448               dephii=dephii+l*sinkt(m)*(
4449      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4450      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4451      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4452      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4453               dephii1=dephii1+(k-l)*sinkt(m)*(
4454      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4455      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4456      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4457      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4458               if (lprn) then
4459               write (iout,*) "m",m," k",k," l",l," ffthet",
4460      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4461      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4462      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4463      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4464      &            " ethetai",ethetai
4465               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4466      &            cosph1ph2(k,l)*sinkt(m),
4467      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4468               endif
4469             enddo
4470           enddo
4471         enddo
4472 10      continue
4473         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4474      &   i,theta(i)*rad2deg,phii*rad2deg,
4475      &   phii1*rad2deg,ethetai
4476         etheta=etheta+ethetai
4477         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4478         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4479 c        gloc(nphi+i-2,icg)=wang*dethetai
4480         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4481       enddo
4482 C now constrains
4483       ethetacnstr=0.0d0
4484 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4485       do i=1,ntheta_constr
4486         itheta=itheta_constr(i)
4487         thetiii=theta(itheta)
4488         difi=pinorm(thetiii-theta_constr0(i))
4489         if (difi.gt.theta_drange(i)) then
4490           difi=difi-theta_drange(i)
4491           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4492           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4493      &    +for_thet_constr(i)*difi**3
4494         else if (difi.lt.-drange(i)) then
4495           difi=difi+drange(i)
4496           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4497           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4498      &    +for_thet_constr(i)*difi**3
4499         else
4500           difi=0.0
4501         endif
4502 C       if (energy_dec) then
4503 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4504 C     &    i,itheta,rad2deg*thetiii,
4505 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4506 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4507 C     &    gloc(itheta+nphi-2,icg)
4508 C        endif
4509       enddo
4510       return
4511       end
4512 #endif
4513 #ifdef CRYST_SC
4514 c-----------------------------------------------------------------------------
4515       subroutine esc(escloc)
4516 C Calculate the local energy of a side chain and its derivatives in the
4517 C corresponding virtual-bond valence angles THETA and the spherical angles
4518 C ALPHA and OMEGA.
4519       implicit real*8 (a-h,o-z)
4520       include 'DIMENSIONS'
4521       include 'DIMENSIONS.ZSCOPT'
4522       include 'COMMON.GEO'
4523       include 'COMMON.LOCAL'
4524       include 'COMMON.VAR'
4525       include 'COMMON.INTERACT'
4526       include 'COMMON.DERIV'
4527       include 'COMMON.CHAIN'
4528       include 'COMMON.IOUNITS'
4529       include 'COMMON.NAMES'
4530       include 'COMMON.FFIELD'
4531       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4532      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4533       common /sccalc/ time11,time12,time112,theti,it,nlobit
4534       delta=0.02d0*pi
4535       escloc=0.0D0
4536 C      write (iout,*) 'ESC'
4537       do i=loc_start,loc_end
4538         it=itype(i)
4539         if (it.eq.ntyp1) cycle
4540         if (it.eq.10) goto 1
4541         nlobit=nlob(iabs(it))
4542 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4543 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4544         theti=theta(i+1)-pipol
4545         x(1)=dtan(theti)
4546         x(2)=alph(i)
4547         x(3)=omeg(i)
4548 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4549
4550         if (x(2).gt.pi-delta) then
4551           xtemp(1)=x(1)
4552           xtemp(2)=pi-delta
4553           xtemp(3)=x(3)
4554           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4555           xtemp(2)=pi
4556           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4557           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4558      &        escloci,dersc(2))
4559           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4560      &        ddersc0(1),dersc(1))
4561           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4562      &        ddersc0(3),dersc(3))
4563           xtemp(2)=pi-delta
4564           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4565           xtemp(2)=pi
4566           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4567           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4568      &            dersc0(2),esclocbi,dersc02)
4569           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4570      &            dersc12,dersc01)
4571           call splinthet(x(2),0.5d0*delta,ss,ssd)
4572           dersc0(1)=dersc01
4573           dersc0(2)=dersc02
4574           dersc0(3)=0.0d0
4575           do k=1,3
4576             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4577           enddo
4578           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4579           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4580      &             esclocbi,ss,ssd
4581           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4582 c         escloci=esclocbi
4583 c         write (iout,*) escloci
4584         else if (x(2).lt.delta) then
4585           xtemp(1)=x(1)
4586           xtemp(2)=delta
4587           xtemp(3)=x(3)
4588           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4589           xtemp(2)=0.0d0
4590           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4591           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4592      &        escloci,dersc(2))
4593           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4594      &        ddersc0(1),dersc(1))
4595           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4596      &        ddersc0(3),dersc(3))
4597           xtemp(2)=delta
4598           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4599           xtemp(2)=0.0d0
4600           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4601           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4602      &            dersc0(2),esclocbi,dersc02)
4603           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4604      &            dersc12,dersc01)
4605           dersc0(1)=dersc01
4606           dersc0(2)=dersc02
4607           dersc0(3)=0.0d0
4608           call splinthet(x(2),0.5d0*delta,ss,ssd)
4609           do k=1,3
4610             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4611           enddo
4612           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4613 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4614 c     &             esclocbi,ss,ssd
4615           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4616 C         write (iout,*) 'i=',i, escloci
4617         else
4618           call enesc(x,escloci,dersc,ddummy,.false.)
4619         endif
4620
4621         escloc=escloc+escloci
4622 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4623             write (iout,'(a6,i5,0pf7.3)')
4624      &     'escloc',i,escloci
4625
4626         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4627      &   wscloc*dersc(1)
4628         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4629         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4630     1   continue
4631       enddo
4632       return
4633       end
4634 C---------------------------------------------------------------------------
4635       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4636       implicit real*8 (a-h,o-z)
4637       include 'DIMENSIONS'
4638       include 'COMMON.GEO'
4639       include 'COMMON.LOCAL'
4640       include 'COMMON.IOUNITS'
4641       common /sccalc/ time11,time12,time112,theti,it,nlobit
4642       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4643       double precision contr(maxlob,-1:1)
4644       logical mixed
4645 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4646         escloc_i=0.0D0
4647         do j=1,3
4648           dersc(j)=0.0D0
4649           if (mixed) ddersc(j)=0.0d0
4650         enddo
4651         x3=x(3)
4652
4653 C Because of periodicity of the dependence of the SC energy in omega we have
4654 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4655 C To avoid underflows, first compute & store the exponents.
4656
4657         do iii=-1,1
4658
4659           x(3)=x3+iii*dwapi
4660
4661           do j=1,nlobit
4662             do k=1,3
4663               z(k)=x(k)-censc(k,j,it)
4664             enddo
4665             do k=1,3
4666               Axk=0.0D0
4667               do l=1,3
4668                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4669               enddo
4670               Ax(k,j,iii)=Axk
4671             enddo
4672             expfac=0.0D0
4673             do k=1,3
4674               expfac=expfac+Ax(k,j,iii)*z(k)
4675             enddo
4676             contr(j,iii)=expfac
4677           enddo ! j
4678
4679         enddo ! iii
4680
4681         x(3)=x3
4682 C As in the case of ebend, we want to avoid underflows in exponentiation and
4683 C subsequent NaNs and INFs in energy calculation.
4684 C Find the largest exponent
4685         emin=contr(1,-1)
4686         do iii=-1,1
4687           do j=1,nlobit
4688             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4689           enddo
4690         enddo
4691         emin=0.5D0*emin
4692 cd      print *,'it=',it,' emin=',emin
4693
4694 C Compute the contribution to SC energy and derivatives
4695         do iii=-1,1
4696
4697           do j=1,nlobit
4698             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4699 cd          print *,'j=',j,' expfac=',expfac
4700             escloc_i=escloc_i+expfac
4701             do k=1,3
4702               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4703             enddo
4704             if (mixed) then
4705               do k=1,3,2
4706                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4707      &            +gaussc(k,2,j,it))*expfac
4708               enddo
4709             endif
4710           enddo
4711
4712         enddo ! iii
4713
4714         dersc(1)=dersc(1)/cos(theti)**2
4715         ddersc(1)=ddersc(1)/cos(theti)**2
4716         ddersc(3)=ddersc(3)
4717
4718         escloci=-(dlog(escloc_i)-emin)
4719         do j=1,3
4720           dersc(j)=dersc(j)/escloc_i
4721         enddo
4722         if (mixed) then
4723           do j=1,3,2
4724             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4725           enddo
4726         endif
4727       return
4728       end
4729 C------------------------------------------------------------------------------
4730       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4731       implicit real*8 (a-h,o-z)
4732       include 'DIMENSIONS'
4733       include 'COMMON.GEO'
4734       include 'COMMON.LOCAL'
4735       include 'COMMON.IOUNITS'
4736       common /sccalc/ time11,time12,time112,theti,it,nlobit
4737       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4738       double precision contr(maxlob)
4739       logical mixed
4740
4741       escloc_i=0.0D0
4742
4743       do j=1,3
4744         dersc(j)=0.0D0
4745       enddo
4746
4747       do j=1,nlobit
4748         do k=1,2
4749           z(k)=x(k)-censc(k,j,it)
4750         enddo
4751         z(3)=dwapi
4752         do k=1,3
4753           Axk=0.0D0
4754           do l=1,3
4755             Axk=Axk+gaussc(l,k,j,it)*z(l)
4756           enddo
4757           Ax(k,j)=Axk
4758         enddo
4759         expfac=0.0D0
4760         do k=1,3
4761           expfac=expfac+Ax(k,j)*z(k)
4762         enddo
4763         contr(j)=expfac
4764       enddo ! j
4765
4766 C As in the case of ebend, we want to avoid underflows in exponentiation and
4767 C subsequent NaNs and INFs in energy calculation.
4768 C Find the largest exponent
4769       emin=contr(1)
4770       do j=1,nlobit
4771         if (emin.gt.contr(j)) emin=contr(j)
4772       enddo
4773       emin=0.5D0*emin
4774
4775 C Compute the contribution to SC energy and derivatives
4776
4777       dersc12=0.0d0
4778       do j=1,nlobit
4779         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4780         escloc_i=escloc_i+expfac
4781         do k=1,2
4782           dersc(k)=dersc(k)+Ax(k,j)*expfac
4783         enddo
4784         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4785      &            +gaussc(1,2,j,it))*expfac
4786         dersc(3)=0.0d0
4787       enddo
4788
4789       dersc(1)=dersc(1)/cos(theti)**2
4790       dersc12=dersc12/cos(theti)**2
4791       escloci=-(dlog(escloc_i)-emin)
4792       do j=1,2
4793         dersc(j)=dersc(j)/escloc_i
4794       enddo
4795       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4796       return
4797       end
4798 #else
4799 c----------------------------------------------------------------------------------
4800       subroutine esc(escloc)
4801 C Calculate the local energy of a side chain and its derivatives in the
4802 C corresponding virtual-bond valence angles THETA and the spherical angles
4803 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4804 C added by Urszula Kozlowska. 07/11/2007
4805 C
4806       implicit real*8 (a-h,o-z)
4807       include 'DIMENSIONS'
4808       include 'DIMENSIONS.ZSCOPT'
4809       include 'COMMON.GEO'
4810       include 'COMMON.LOCAL'
4811       include 'COMMON.VAR'
4812       include 'COMMON.SCROT'
4813       include 'COMMON.INTERACT'
4814       include 'COMMON.DERIV'
4815       include 'COMMON.CHAIN'
4816       include 'COMMON.IOUNITS'
4817       include 'COMMON.NAMES'
4818       include 'COMMON.FFIELD'
4819       include 'COMMON.CONTROL'
4820       include 'COMMON.VECTORS'
4821       double precision x_prime(3),y_prime(3),z_prime(3)
4822      &    , sumene,dsc_i,dp2_i,x(65),
4823      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4824      &    de_dxx,de_dyy,de_dzz,de_dt
4825       double precision s1_t,s1_6_t,s2_t,s2_6_t
4826       double precision
4827      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4828      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4829      & dt_dCi(3),dt_dCi1(3)
4830       common /sccalc/ time11,time12,time112,theti,it,nlobit
4831       delta=0.02d0*pi
4832       escloc=0.0D0
4833       do i=loc_start,loc_end
4834         if (itype(i).eq.ntyp1) cycle
4835         costtab(i+1) =dcos(theta(i+1))
4836         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4837         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4838         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4839         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4840         cosfac=dsqrt(cosfac2)
4841         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4842         sinfac=dsqrt(sinfac2)
4843         it=iabs(itype(i))
4844         if (it.eq.10) goto 1
4845 c
4846 C  Compute the axes of tghe local cartesian coordinates system; store in
4847 c   x_prime, y_prime and z_prime
4848 c
4849         do j=1,3
4850           x_prime(j) = 0.00
4851           y_prime(j) = 0.00
4852           z_prime(j) = 0.00
4853         enddo
4854 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4855 C     &   dc_norm(3,i+nres)
4856         do j = 1,3
4857           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4858           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4859         enddo
4860         do j = 1,3
4861           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4862         enddo
4863 c       write (2,*) "i",i
4864 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4865 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4866 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4867 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4868 c      & " xy",scalar(x_prime(1),y_prime(1)),
4869 c      & " xz",scalar(x_prime(1),z_prime(1)),
4870 c      & " yy",scalar(y_prime(1),y_prime(1)),
4871 c      & " yz",scalar(y_prime(1),z_prime(1)),
4872 c      & " zz",scalar(z_prime(1),z_prime(1))
4873 c
4874 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4875 C to local coordinate system. Store in xx, yy, zz.
4876 c
4877         xx=0.0d0
4878         yy=0.0d0
4879         zz=0.0d0
4880         do j = 1,3
4881           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4882           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4883           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4884         enddo
4885
4886         xxtab(i)=xx
4887         yytab(i)=yy
4888         zztab(i)=zz
4889 C
4890 C Compute the energy of the ith side cbain
4891 C
4892 c        write (2,*) "xx",xx," yy",yy," zz",zz
4893         it=iabs(itype(i))
4894         do j = 1,65
4895           x(j) = sc_parmin(j,it)
4896         enddo
4897 #ifdef CHECK_COORD
4898 Cc diagnostics - remove later
4899         xx1 = dcos(alph(2))
4900         yy1 = dsin(alph(2))*dcos(omeg(2))
4901         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4902         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4903      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4904      &    xx1,yy1,zz1
4905 C,"  --- ", xx_w,yy_w,zz_w
4906 c end diagnostics
4907 #endif
4908         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4909      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4910      &   + x(10)*yy*zz
4911         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4912      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4913      & + x(20)*yy*zz
4914         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4915      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4916      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4917      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4918      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4919      &  +x(40)*xx*yy*zz
4920         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4921      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4922      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4923      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4924      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4925      &  +x(60)*xx*yy*zz
4926         dsc_i   = 0.743d0+x(61)
4927         dp2_i   = 1.9d0+x(62)
4928         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4929      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4930         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4931      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4932         s1=(1+x(63))/(0.1d0 + dscp1)
4933         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4934         s2=(1+x(65))/(0.1d0 + dscp2)
4935         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4936         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4937      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4938 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4939 c     &   sumene4,
4940 c     &   dscp1,dscp2,sumene
4941 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4942         escloc = escloc + sumene
4943 c        write (2,*) "escloc",escloc
4944 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
4945 c     &  zz,xx,yy
4946         if (.not. calc_grad) goto 1
4947 #ifdef DEBUG
4948 C
4949 C This section to check the numerical derivatives of the energy of ith side
4950 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4951 C #define DEBUG in the code to turn it on.
4952 C
4953         write (2,*) "sumene               =",sumene
4954         aincr=1.0d-7
4955         xxsave=xx
4956         xx=xx+aincr
4957         write (2,*) xx,yy,zz
4958         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4959         de_dxx_num=(sumenep-sumene)/aincr
4960         xx=xxsave
4961         write (2,*) "xx+ sumene from enesc=",sumenep
4962         yysave=yy
4963         yy=yy+aincr
4964         write (2,*) xx,yy,zz
4965         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4966         de_dyy_num=(sumenep-sumene)/aincr
4967         yy=yysave
4968         write (2,*) "yy+ sumene from enesc=",sumenep
4969         zzsave=zz
4970         zz=zz+aincr
4971         write (2,*) xx,yy,zz
4972         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4973         de_dzz_num=(sumenep-sumene)/aincr
4974         zz=zzsave
4975         write (2,*) "zz+ sumene from enesc=",sumenep
4976         costsave=cost2tab(i+1)
4977         sintsave=sint2tab(i+1)
4978         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4979         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4980         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4981         de_dt_num=(sumenep-sumene)/aincr
4982         write (2,*) " t+ sumene from enesc=",sumenep
4983         cost2tab(i+1)=costsave
4984         sint2tab(i+1)=sintsave
4985 C End of diagnostics section.
4986 #endif
4987 C
4988 C Compute the gradient of esc
4989 C
4990         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4991         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4992         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4993         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4994         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4995         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4996         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4997         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4998         pom1=(sumene3*sint2tab(i+1)+sumene1)
4999      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5000         pom2=(sumene4*cost2tab(i+1)+sumene2)
5001      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5002         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5003         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5004      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5005      &  +x(40)*yy*zz
5006         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5007         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5008      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5009      &  +x(60)*yy*zz
5010         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5011      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5012      &        +(pom1+pom2)*pom_dx
5013 #ifdef DEBUG
5014         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5015 #endif
5016 C
5017         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5018         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5019      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5020      &  +x(40)*xx*zz
5021         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5022         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5023      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5024      &  +x(59)*zz**2 +x(60)*xx*zz
5025         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5026      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5027      &        +(pom1-pom2)*pom_dy
5028 #ifdef DEBUG
5029         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5030 #endif
5031 C
5032         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5033      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5034      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5035      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5036      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5037      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5038      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5039      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5040 #ifdef DEBUG
5041         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5042 #endif
5043 C
5044         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5045      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5046      &  +pom1*pom_dt1+pom2*pom_dt2
5047 #ifdef DEBUG
5048         write(2,*), "de_dt = ", de_dt,de_dt_num
5049 #endif
5050 c
5051 C
5052        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5053        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5054        cosfac2xx=cosfac2*xx
5055        sinfac2yy=sinfac2*yy
5056        do k = 1,3
5057          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5058      &      vbld_inv(i+1)
5059          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5060      &      vbld_inv(i)
5061          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5062          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5063 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5064 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5065 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5066 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5067          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5068          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5069          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5070          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5071          dZZ_Ci1(k)=0.0d0
5072          dZZ_Ci(k)=0.0d0
5073          do j=1,3
5074            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5075      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5076            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5077      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5078          enddo
5079
5080          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5081          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5082          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5083 c
5084          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5085          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5086        enddo
5087
5088        do k=1,3
5089          dXX_Ctab(k,i)=dXX_Ci(k)
5090          dXX_C1tab(k,i)=dXX_Ci1(k)
5091          dYY_Ctab(k,i)=dYY_Ci(k)
5092          dYY_C1tab(k,i)=dYY_Ci1(k)
5093          dZZ_Ctab(k,i)=dZZ_Ci(k)
5094          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5095          dXX_XYZtab(k,i)=dXX_XYZ(k)
5096          dYY_XYZtab(k,i)=dYY_XYZ(k)
5097          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5098        enddo
5099
5100        do k = 1,3
5101 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5102 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5103 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5104 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5105 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5106 c     &    dt_dci(k)
5107 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5108 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5109          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5110      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5111          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5112      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5113          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5114      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5115        enddo
5116 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5117 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5118
5119 C to check gradient call subroutine check_grad
5120
5121     1 continue
5122       enddo
5123       return
5124       end
5125 #endif
5126 c------------------------------------------------------------------------------
5127       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5128 C
5129 C This procedure calculates two-body contact function g(rij) and its derivative:
5130 C
5131 C           eps0ij                                     !       x < -1
5132 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5133 C            0                                         !       x > 1
5134 C
5135 C where x=(rij-r0ij)/delta
5136 C
5137 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5138 C
5139       implicit none
5140       double precision rij,r0ij,eps0ij,fcont,fprimcont
5141       double precision x,x2,x4,delta
5142 c     delta=0.02D0*r0ij
5143 c      delta=0.2D0*r0ij
5144       x=(rij-r0ij)/delta
5145       if (x.lt.-1.0D0) then
5146         fcont=eps0ij
5147         fprimcont=0.0D0
5148       else if (x.le.1.0D0) then
5149         x2=x*x
5150         x4=x2*x2
5151         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5152         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5153       else
5154         fcont=0.0D0
5155         fprimcont=0.0D0
5156       endif
5157       return
5158       end
5159 c------------------------------------------------------------------------------
5160       subroutine splinthet(theti,delta,ss,ssder)
5161       implicit real*8 (a-h,o-z)
5162       include 'DIMENSIONS'
5163       include 'DIMENSIONS.ZSCOPT'
5164       include 'COMMON.VAR'
5165       include 'COMMON.GEO'
5166       thetup=pi-delta
5167       thetlow=delta
5168       if (theti.gt.pipol) then
5169         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5170       else
5171         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5172         ssder=-ssder
5173       endif
5174       return
5175       end
5176 c------------------------------------------------------------------------------
5177       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5178       implicit none
5179       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5180       double precision ksi,ksi2,ksi3,a1,a2,a3
5181       a1=fprim0*delta/(f1-f0)
5182       a2=3.0d0-2.0d0*a1
5183       a3=a1-2.0d0
5184       ksi=(x-x0)/delta
5185       ksi2=ksi*ksi
5186       ksi3=ksi2*ksi
5187       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5188       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5189       return
5190       end
5191 c------------------------------------------------------------------------------
5192       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5193       implicit none
5194       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5195       double precision ksi,ksi2,ksi3,a1,a2,a3
5196       ksi=(x-x0)/delta
5197       ksi2=ksi*ksi
5198       ksi3=ksi2*ksi
5199       a1=fprim0x*delta
5200       a2=3*(f1x-f0x)-2*fprim0x*delta
5201       a3=fprim0x*delta-2*(f1x-f0x)
5202       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5203       return
5204       end
5205 C-----------------------------------------------------------------------------
5206 #ifdef CRYST_TOR
5207 C-----------------------------------------------------------------------------
5208       subroutine etor(etors,edihcnstr,fact)
5209       implicit real*8 (a-h,o-z)
5210       include 'DIMENSIONS'
5211       include 'DIMENSIONS.ZSCOPT'
5212       include 'COMMON.VAR'
5213       include 'COMMON.GEO'
5214       include 'COMMON.LOCAL'
5215       include 'COMMON.TORSION'
5216       include 'COMMON.INTERACT'
5217       include 'COMMON.DERIV'
5218       include 'COMMON.CHAIN'
5219       include 'COMMON.NAMES'
5220       include 'COMMON.IOUNITS'
5221       include 'COMMON.FFIELD'
5222       include 'COMMON.TORCNSTR'
5223       logical lprn
5224 C Set lprn=.true. for debugging
5225       lprn=.false.
5226 c      lprn=.true.
5227       etors=0.0D0
5228       do i=iphi_start,iphi_end
5229         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5230      &      .or. itype(i).eq.ntyp1) cycle
5231         itori=itortyp(itype(i-2))
5232         itori1=itortyp(itype(i-1))
5233         phii=phi(i)
5234         gloci=0.0D0
5235 C Proline-Proline pair is a special case...
5236         if (itori.eq.3 .and. itori1.eq.3) then
5237           if (phii.gt.-dwapi3) then
5238             cosphi=dcos(3*phii)
5239             fac=1.0D0/(1.0D0-cosphi)
5240             etorsi=v1(1,3,3)*fac
5241             etorsi=etorsi+etorsi
5242             etors=etors+etorsi-v1(1,3,3)
5243             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5244           endif
5245           do j=1,3
5246             v1ij=v1(j+1,itori,itori1)
5247             v2ij=v2(j+1,itori,itori1)
5248             cosphi=dcos(j*phii)
5249             sinphi=dsin(j*phii)
5250             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5251             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5252           enddo
5253         else
5254           do j=1,nterm_old
5255             v1ij=v1(j,itori,itori1)
5256             v2ij=v2(j,itori,itori1)
5257             cosphi=dcos(j*phii)
5258             sinphi=dsin(j*phii)
5259             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5260             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5261           enddo
5262         endif
5263         if (lprn)
5264      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5265      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5266      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5267         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5268 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5269       enddo
5270 ! 6/20/98 - dihedral angle constraints
5271       edihcnstr=0.0d0
5272       do i=1,ndih_constr
5273         itori=idih_constr(i)
5274         phii=phi(itori)
5275         difi=phii-phi0(i)
5276         if (difi.gt.drange(i)) then
5277           difi=difi-drange(i)
5278           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5279           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5280         else if (difi.lt.-drange(i)) then
5281           difi=difi+drange(i)
5282           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5283           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5284         endif
5285 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5286 C     &    i,itori,rad2deg*phii,
5287 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5288       enddo
5289 !      write (iout,*) 'edihcnstr',edihcnstr
5290       return
5291       end
5292 c------------------------------------------------------------------------------
5293 #else
5294       subroutine etor(etors,edihcnstr,fact)
5295       implicit real*8 (a-h,o-z)
5296       include 'DIMENSIONS'
5297       include 'DIMENSIONS.ZSCOPT'
5298       include 'COMMON.VAR'
5299       include 'COMMON.GEO'
5300       include 'COMMON.LOCAL'
5301       include 'COMMON.TORSION'
5302       include 'COMMON.INTERACT'
5303       include 'COMMON.DERIV'
5304       include 'COMMON.CHAIN'
5305       include 'COMMON.NAMES'
5306       include 'COMMON.IOUNITS'
5307       include 'COMMON.FFIELD'
5308       include 'COMMON.TORCNSTR'
5309       logical lprn
5310 C Set lprn=.true. for debugging
5311       lprn=.false.
5312 c      lprn=.true.
5313       etors=0.0D0
5314       do i=iphi_start,iphi_end
5315         if (i.le.2) cycle
5316         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5317      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5318 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5319 C     &       .or. itype(i).eq.ntyp1) cycle
5320         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5321          if (iabs(itype(i)).eq.20) then
5322          iblock=2
5323          else
5324          iblock=1
5325          endif
5326         itori=itortyp(itype(i-2))
5327         itori1=itortyp(itype(i-1))
5328         phii=phi(i)
5329         gloci=0.0D0
5330 C Regular cosine and sine terms
5331         do j=1,nterm(itori,itori1,iblock)
5332           v1ij=v1(j,itori,itori1,iblock)
5333           v2ij=v2(j,itori,itori1,iblock)
5334           cosphi=dcos(j*phii)
5335           sinphi=dsin(j*phii)
5336           etors=etors+v1ij*cosphi+v2ij*sinphi
5337           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5338         enddo
5339 C Lorentz terms
5340 C                         v1
5341 C  E = SUM ----------------------------------- - v1
5342 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5343 C
5344         cosphi=dcos(0.5d0*phii)
5345         sinphi=dsin(0.5d0*phii)
5346         do j=1,nlor(itori,itori1,iblock)
5347           vl1ij=vlor1(j,itori,itori1)
5348           vl2ij=vlor2(j,itori,itori1)
5349           vl3ij=vlor3(j,itori,itori1)
5350           pom=vl2ij*cosphi+vl3ij*sinphi
5351           pom1=1.0d0/(pom*pom+1.0d0)
5352           etors=etors+vl1ij*pom1
5353 c          if (energy_dec) etors_ii=etors_ii+
5354 c     &                vl1ij*pom1
5355           pom=-pom*pom1*pom1
5356           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5357         enddo
5358 C Subtract the constant term
5359         etors=etors-v0(itori,itori1,iblock)
5360         if (lprn)
5361      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5362      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5363      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5364         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5365 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5366  1215   continue
5367       enddo
5368 ! 6/20/98 - dihedral angle constraints
5369       edihcnstr=0.0d0
5370       do i=1,ndih_constr
5371         itori=idih_constr(i)
5372         phii=phi(itori)
5373         difi=pinorm(phii-phi0(i))
5374         edihi=0.0d0
5375         if (difi.gt.drange(i)) then
5376           difi=difi-drange(i)
5377           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5378           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5379           edihi=0.25d0*ftors(i)*difi**4
5380         else if (difi.lt.-drange(i)) then
5381           difi=difi+drange(i)
5382           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5383           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5384           edihi=0.25d0*ftors(i)*difi**4
5385         else
5386           difi=0.0d0
5387         endif
5388         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5389      &    i,itori,rad2deg*phii,
5390      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5391 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5392 c     &    drange(i),edihi
5393 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5394 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5395       enddo
5396 !      write (iout,*) 'edihcnstr',edihcnstr
5397       return
5398       end
5399 c----------------------------------------------------------------------------
5400       subroutine etor_d(etors_d,fact2)
5401 C 6/23/01 Compute double torsional energy
5402       implicit real*8 (a-h,o-z)
5403       include 'DIMENSIONS'
5404       include 'DIMENSIONS.ZSCOPT'
5405       include 'COMMON.VAR'
5406       include 'COMMON.GEO'
5407       include 'COMMON.LOCAL'
5408       include 'COMMON.TORSION'
5409       include 'COMMON.INTERACT'
5410       include 'COMMON.DERIV'
5411       include 'COMMON.CHAIN'
5412       include 'COMMON.NAMES'
5413       include 'COMMON.IOUNITS'
5414       include 'COMMON.FFIELD'
5415       include 'COMMON.TORCNSTR'
5416       logical lprn
5417 C Set lprn=.true. for debugging
5418       lprn=.false.
5419 c     lprn=.true.
5420       etors_d=0.0D0
5421       do i=iphi_start,iphi_end-1
5422         if (i.le.3) cycle
5423 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5424 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5425          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5426      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5427      &  (itype(i+1).eq.ntyp1)) cycle
5428         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5429      &     goto 1215
5430         itori=itortyp(itype(i-2))
5431         itori1=itortyp(itype(i-1))
5432         itori2=itortyp(itype(i))
5433         phii=phi(i)
5434         phii1=phi(i+1)
5435         gloci1=0.0D0
5436         gloci2=0.0D0
5437         iblock=1
5438         if (iabs(itype(i+1)).eq.20) iblock=2
5439 C Regular cosine and sine terms
5440         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5441           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5442           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5443           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5444           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5445           cosphi1=dcos(j*phii)
5446           sinphi1=dsin(j*phii)
5447           cosphi2=dcos(j*phii1)
5448           sinphi2=dsin(j*phii1)
5449           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5450      &     v2cij*cosphi2+v2sij*sinphi2
5451           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5452           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5453         enddo
5454         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5455           do l=1,k-1
5456             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5457             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5458             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5459             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5460             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5461             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5462             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5463             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5464             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5465      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5466             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5467      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5468             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5469      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5470           enddo
5471         enddo
5472         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5473         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5474  1215   continue
5475       enddo
5476       return
5477       end
5478 #endif
5479 c------------------------------------------------------------------------------
5480       subroutine eback_sc_corr(esccor)
5481 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5482 c        conformational states; temporarily implemented as differences
5483 c        between UNRES torsional potentials (dependent on three types of
5484 c        residues) and the torsional potentials dependent on all 20 types
5485 c        of residues computed from AM1 energy surfaces of terminally-blocked
5486 c        amino-acid residues.
5487       implicit real*8 (a-h,o-z)
5488       include 'DIMENSIONS'
5489       include 'DIMENSIONS.ZSCOPT'
5490       include 'COMMON.VAR'
5491       include 'COMMON.GEO'
5492       include 'COMMON.LOCAL'
5493       include 'COMMON.TORSION'
5494       include 'COMMON.SCCOR'
5495       include 'COMMON.INTERACT'
5496       include 'COMMON.DERIV'
5497       include 'COMMON.CHAIN'
5498       include 'COMMON.NAMES'
5499       include 'COMMON.IOUNITS'
5500       include 'COMMON.FFIELD'
5501       include 'COMMON.CONTROL'
5502       logical lprn
5503 C Set lprn=.true. for debugging
5504       lprn=.false.
5505 c      lprn=.true.
5506 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5507       esccor=0.0D0
5508       do i=itau_start,itau_end
5509         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5510         esccor_ii=0.0D0
5511         isccori=isccortyp(itype(i-2))
5512         isccori1=isccortyp(itype(i-1))
5513         phii=phi(i)
5514         do intertyp=1,3 !intertyp
5515 cc Added 09 May 2012 (Adasko)
5516 cc  Intertyp means interaction type of backbone mainchain correlation:
5517 c   1 = SC...Ca...Ca...Ca
5518 c   2 = Ca...Ca...Ca...SC
5519 c   3 = SC...Ca...Ca...SCi
5520         gloci=0.0D0
5521         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5522      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5523      &      (itype(i-1).eq.ntyp1)))
5524      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5525      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5526      &     .or.(itype(i).eq.ntyp1)))
5527      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5528      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5529      &      (itype(i-3).eq.ntyp1)))) cycle
5530         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5531         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5532      & cycle
5533        do j=1,nterm_sccor(isccori,isccori1)
5534           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5535           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5536           cosphi=dcos(j*tauangle(intertyp,i))
5537           sinphi=dsin(j*tauangle(intertyp,i))
5538            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5539            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5540          enddo
5541 C      write (iout,*)"EBACK_SC_COR",esccor,i
5542 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5543 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5544 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5545         if (lprn)
5546      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5547      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5548      &  (v1sccor(j,1,itori,itori1),j=1,6)
5549      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5550 c        gsccor_loc(i-3)=gloci
5551        enddo !intertyp
5552       enddo
5553       return
5554       end
5555 c------------------------------------------------------------------------------
5556       subroutine multibody(ecorr)
5557 C This subroutine calculates multi-body contributions to energy following
5558 C the idea of Skolnick et al. If side chains I and J make a contact and
5559 C at the same time side chains I+1 and J+1 make a contact, an extra
5560 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5561       implicit real*8 (a-h,o-z)
5562       include 'DIMENSIONS'
5563       include 'COMMON.IOUNITS'
5564       include 'COMMON.DERIV'
5565       include 'COMMON.INTERACT'
5566       include 'COMMON.CONTACTS'
5567       double precision gx(3),gx1(3)
5568       logical lprn
5569
5570 C Set lprn=.true. for debugging
5571       lprn=.false.
5572
5573       if (lprn) then
5574         write (iout,'(a)') 'Contact function values:'
5575         do i=nnt,nct-2
5576           write (iout,'(i2,20(1x,i2,f10.5))')
5577      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5578         enddo
5579       endif
5580       ecorr=0.0D0
5581       do i=nnt,nct
5582         do j=1,3
5583           gradcorr(j,i)=0.0D0
5584           gradxorr(j,i)=0.0D0
5585         enddo
5586       enddo
5587       do i=nnt,nct-2
5588
5589         DO ISHIFT = 3,4
5590
5591         i1=i+ishift
5592         num_conti=num_cont(i)
5593         num_conti1=num_cont(i1)
5594         do jj=1,num_conti
5595           j=jcont(jj,i)
5596           do kk=1,num_conti1
5597             j1=jcont(kk,i1)
5598             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5599 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5600 cd   &                   ' ishift=',ishift
5601 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5602 C The system gains extra energy.
5603               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5604             endif   ! j1==j+-ishift
5605           enddo     ! kk
5606         enddo       ! jj
5607
5608         ENDDO ! ISHIFT
5609
5610       enddo         ! i
5611       return
5612       end
5613 c------------------------------------------------------------------------------
5614       double precision function esccorr(i,j,k,l,jj,kk)
5615       implicit real*8 (a-h,o-z)
5616       include 'DIMENSIONS'
5617       include 'COMMON.IOUNITS'
5618       include 'COMMON.DERIV'
5619       include 'COMMON.INTERACT'
5620       include 'COMMON.CONTACTS'
5621       double precision gx(3),gx1(3)
5622       logical lprn
5623       lprn=.false.
5624       eij=facont(jj,i)
5625       ekl=facont(kk,k)
5626 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5627 C Calculate the multi-body contribution to energy.
5628 C Calculate multi-body contributions to the gradient.
5629 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5630 cd   & k,l,(gacont(m,kk,k),m=1,3)
5631       do m=1,3
5632         gx(m) =ekl*gacont(m,jj,i)
5633         gx1(m)=eij*gacont(m,kk,k)
5634         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5635         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5636         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5637         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5638       enddo
5639       do m=i,j-1
5640         do ll=1,3
5641           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5642         enddo
5643       enddo
5644       do m=k,l-1
5645         do ll=1,3
5646           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5647         enddo
5648       enddo
5649       esccorr=-eij*ekl
5650       return
5651       end
5652 c------------------------------------------------------------------------------
5653 #ifdef MPL
5654       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5655       implicit real*8 (a-h,o-z)
5656       include 'DIMENSIONS'
5657       integer dimen1,dimen2,atom,indx
5658       double precision buffer(dimen1,dimen2)
5659       double precision zapas
5660       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5661      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5662      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5663       num_kont=num_cont_hb(atom)
5664       do i=1,num_kont
5665         do k=1,7
5666           do j=1,3
5667             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5668           enddo ! j
5669         enddo ! k
5670         buffer(i,indx+22)=facont_hb(i,atom)
5671         buffer(i,indx+23)=ees0p(i,atom)
5672         buffer(i,indx+24)=ees0m(i,atom)
5673         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5674       enddo ! i
5675       buffer(1,indx+26)=dfloat(num_kont)
5676       return
5677       end
5678 c------------------------------------------------------------------------------
5679       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5680       implicit real*8 (a-h,o-z)
5681       include 'DIMENSIONS'
5682       integer dimen1,dimen2,atom,indx
5683       double precision buffer(dimen1,dimen2)
5684       double precision zapas
5685       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5686      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5687      &         ees0m(ntyp,maxres),
5688      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5689       num_kont=buffer(1,indx+26)
5690       num_kont_old=num_cont_hb(atom)
5691       num_cont_hb(atom)=num_kont+num_kont_old
5692       do i=1,num_kont
5693         ii=i+num_kont_old
5694         do k=1,7
5695           do j=1,3
5696             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5697           enddo ! j
5698         enddo ! k
5699         facont_hb(ii,atom)=buffer(i,indx+22)
5700         ees0p(ii,atom)=buffer(i,indx+23)
5701         ees0m(ii,atom)=buffer(i,indx+24)
5702         jcont_hb(ii,atom)=buffer(i,indx+25)
5703       enddo ! i
5704       return
5705       end
5706 c------------------------------------------------------------------------------
5707 #endif
5708       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5709 C This subroutine calculates multi-body contributions to hydrogen-bonding
5710       implicit real*8 (a-h,o-z)
5711       include 'DIMENSIONS'
5712       include 'DIMENSIONS.ZSCOPT'
5713       include 'COMMON.IOUNITS'
5714 #ifdef MPL
5715       include 'COMMON.INFO'
5716 #endif
5717       include 'COMMON.FFIELD'
5718       include 'COMMON.DERIV'
5719       include 'COMMON.INTERACT'
5720       include 'COMMON.CONTACTS'
5721 #ifdef MPL
5722       parameter (max_cont=maxconts)
5723       parameter (max_dim=2*(8*3+2))
5724       parameter (msglen1=max_cont*max_dim*4)
5725       parameter (msglen2=2*msglen1)
5726       integer source,CorrelType,CorrelID,Error
5727       double precision buffer(max_cont,max_dim)
5728 #endif
5729       double precision gx(3),gx1(3)
5730       logical lprn,ldone
5731
5732 C Set lprn=.true. for debugging
5733       lprn=.false.
5734 #ifdef MPL
5735       n_corr=0
5736       n_corr1=0
5737       if (fgProcs.le.1) goto 30
5738       if (lprn) then
5739         write (iout,'(a)') 'Contact function values:'
5740         do i=nnt,nct-2
5741           write (iout,'(2i3,50(1x,i2,f5.2))')
5742      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5743      &    j=1,num_cont_hb(i))
5744         enddo
5745       endif
5746 C Caution! Following code assumes that electrostatic interactions concerning
5747 C a given atom are split among at most two processors!
5748       CorrelType=477
5749       CorrelID=MyID+1
5750       ldone=.false.
5751       do i=1,max_cont
5752         do j=1,max_dim
5753           buffer(i,j)=0.0D0
5754         enddo
5755       enddo
5756       mm=mod(MyRank,2)
5757 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5758       if (mm) 20,20,10
5759    10 continue
5760 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5761       if (MyRank.gt.0) then
5762 C Send correlation contributions to the preceding processor
5763         msglen=msglen1
5764         nn=num_cont_hb(iatel_s)
5765         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5766 cd      write (iout,*) 'The BUFFER array:'
5767 cd      do i=1,nn
5768 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5769 cd      enddo
5770         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5771           msglen=msglen2
5772             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5773 C Clear the contacts of the atom passed to the neighboring processor
5774         nn=num_cont_hb(iatel_s+1)
5775 cd      do i=1,nn
5776 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5777 cd      enddo
5778             num_cont_hb(iatel_s)=0
5779         endif
5780 cd      write (iout,*) 'Processor ',MyID,MyRank,
5781 cd   & ' is sending correlation contribution to processor',MyID-1,
5782 cd   & ' msglen=',msglen
5783 cd      write (*,*) 'Processor ',MyID,MyRank,
5784 cd   & ' is sending correlation contribution to processor',MyID-1,
5785 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5786         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5787 cd      write (iout,*) 'Processor ',MyID,
5788 cd   & ' has sent correlation contribution to processor',MyID-1,
5789 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5790 cd      write (*,*) 'Processor ',MyID,
5791 cd   & ' has sent correlation contribution to processor',MyID-1,
5792 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5793         msglen=msglen1
5794       endif ! (MyRank.gt.0)
5795       if (ldone) goto 30
5796       ldone=.true.
5797    20 continue
5798 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5799       if (MyRank.lt.fgProcs-1) then
5800 C Receive correlation contributions from the next processor
5801         msglen=msglen1
5802         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5803 cd      write (iout,*) 'Processor',MyID,
5804 cd   & ' is receiving correlation contribution from processor',MyID+1,
5805 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5806 cd      write (*,*) 'Processor',MyID,
5807 cd   & ' is receiving correlation contribution from processor',MyID+1,
5808 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5809         nbytes=-1
5810         do while (nbytes.le.0)
5811           call mp_probe(MyID+1,CorrelType,nbytes)
5812         enddo
5813 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5814         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5815 cd      write (iout,*) 'Processor',MyID,
5816 cd   & ' has received correlation contribution from processor',MyID+1,
5817 cd   & ' msglen=',msglen,' nbytes=',nbytes
5818 cd      write (iout,*) 'The received BUFFER array:'
5819 cd      do i=1,max_cont
5820 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5821 cd      enddo
5822         if (msglen.eq.msglen1) then
5823           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5824         else if (msglen.eq.msglen2)  then
5825           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5826           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5827         else
5828           write (iout,*)
5829      & 'ERROR!!!! message length changed while processing correlations.'
5830           write (*,*)
5831      & 'ERROR!!!! message length changed while processing correlations.'
5832           call mp_stopall(Error)
5833         endif ! msglen.eq.msglen1
5834       endif ! MyRank.lt.fgProcs-1
5835       if (ldone) goto 30
5836       ldone=.true.
5837       goto 10
5838    30 continue
5839 #endif
5840       if (lprn) then
5841         write (iout,'(a)') 'Contact function values:'
5842         do i=nnt,nct-2
5843           write (iout,'(2i3,50(1x,i2,f5.2))')
5844      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5845      &    j=1,num_cont_hb(i))
5846         enddo
5847       endif
5848       ecorr=0.0D0
5849 C Remove the loop below after debugging !!!
5850       do i=nnt,nct
5851         do j=1,3
5852           gradcorr(j,i)=0.0D0
5853           gradxorr(j,i)=0.0D0
5854         enddo
5855       enddo
5856 C Calculate the local-electrostatic correlation terms
5857       do i=iatel_s,iatel_e+1
5858         i1=i+1
5859         num_conti=num_cont_hb(i)
5860         num_conti1=num_cont_hb(i+1)
5861         do jj=1,num_conti
5862           j=jcont_hb(jj,i)
5863           do kk=1,num_conti1
5864             j1=jcont_hb(kk,i1)
5865 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5866 c     &         ' jj=',jj,' kk=',kk
5867             if (j1.eq.j+1 .or. j1.eq.j-1) then
5868 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5869 C The system gains extra energy.
5870               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5871               n_corr=n_corr+1
5872             else if (j1.eq.j) then
5873 C Contacts I-J and I-(J+1) occur simultaneously.
5874 C The system loses extra energy.
5875 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5876             endif
5877           enddo ! kk
5878           do kk=1,num_conti
5879             j1=jcont_hb(kk,i)
5880 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5881 c    &         ' jj=',jj,' kk=',kk
5882             if (j1.eq.j+1) then
5883 C Contacts I-J and (I+1)-J occur simultaneously.
5884 C The system loses extra energy.
5885 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5886             endif ! j1==j+1
5887           enddo ! kk
5888         enddo ! jj
5889       enddo ! i
5890       return
5891       end
5892 c------------------------------------------------------------------------------
5893       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5894      &  n_corr1)
5895 C This subroutine calculates multi-body contributions to hydrogen-bonding
5896       implicit real*8 (a-h,o-z)
5897       include 'DIMENSIONS'
5898       include 'DIMENSIONS.ZSCOPT'
5899       include 'COMMON.IOUNITS'
5900 #ifdef MPL
5901       include 'COMMON.INFO'
5902 #endif
5903       include 'COMMON.FFIELD'
5904       include 'COMMON.DERIV'
5905       include 'COMMON.INTERACT'
5906       include 'COMMON.CONTACTS'
5907 #ifdef MPL
5908       parameter (max_cont=maxconts)
5909       parameter (max_dim=2*(8*3+2))
5910       parameter (msglen1=max_cont*max_dim*4)
5911       parameter (msglen2=2*msglen1)
5912       integer source,CorrelType,CorrelID,Error
5913       double precision buffer(max_cont,max_dim)
5914 #endif
5915       double precision gx(3),gx1(3)
5916       logical lprn,ldone
5917
5918 C Set lprn=.true. for debugging
5919       lprn=.false.
5920       eturn6=0.0d0
5921       ecorr6=0.0d0
5922 #ifdef MPL
5923       n_corr=0
5924       n_corr1=0
5925       if (fgProcs.le.1) goto 30
5926       if (lprn) then
5927         write (iout,'(a)') 'Contact function values:'
5928         do i=nnt,nct-2
5929           write (iout,'(2i3,50(1x,i2,f5.2))')
5930      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5931      &    j=1,num_cont_hb(i))
5932         enddo
5933       endif
5934 C Caution! Following code assumes that electrostatic interactions concerning
5935 C a given atom are split among at most two processors!
5936       CorrelType=477
5937       CorrelID=MyID+1
5938       ldone=.false.
5939       do i=1,max_cont
5940         do j=1,max_dim
5941           buffer(i,j)=0.0D0
5942         enddo
5943       enddo
5944       mm=mod(MyRank,2)
5945 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5946       if (mm) 20,20,10
5947    10 continue
5948 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5949       if (MyRank.gt.0) then
5950 C Send correlation contributions to the preceding processor
5951         msglen=msglen1
5952         nn=num_cont_hb(iatel_s)
5953         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5954 cd      write (iout,*) 'The BUFFER array:'
5955 cd      do i=1,nn
5956 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5957 cd      enddo
5958         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5959           msglen=msglen2
5960             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5961 C Clear the contacts of the atom passed to the neighboring processor
5962         nn=num_cont_hb(iatel_s+1)
5963 cd      do i=1,nn
5964 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5965 cd      enddo
5966             num_cont_hb(iatel_s)=0
5967         endif
5968 cd      write (iout,*) 'Processor ',MyID,MyRank,
5969 cd   & ' is sending correlation contribution to processor',MyID-1,
5970 cd   & ' msglen=',msglen
5971 cd      write (*,*) 'Processor ',MyID,MyRank,
5972 cd   & ' is sending correlation contribution to processor',MyID-1,
5973 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5974         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5975 cd      write (iout,*) 'Processor ',MyID,
5976 cd   & ' has sent correlation contribution to processor',MyID-1,
5977 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5978 cd      write (*,*) 'Processor ',MyID,
5979 cd   & ' has sent correlation contribution to processor',MyID-1,
5980 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5981         msglen=msglen1
5982       endif ! (MyRank.gt.0)
5983       if (ldone) goto 30
5984       ldone=.true.
5985    20 continue
5986 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5987       if (MyRank.lt.fgProcs-1) then
5988 C Receive correlation contributions from the next processor
5989         msglen=msglen1
5990         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5991 cd      write (iout,*) 'Processor',MyID,
5992 cd   & ' is receiving correlation contribution from processor',MyID+1,
5993 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5994 cd      write (*,*) 'Processor',MyID,
5995 cd   & ' is receiving correlation contribution from processor',MyID+1,
5996 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5997         nbytes=-1
5998         do while (nbytes.le.0)
5999           call mp_probe(MyID+1,CorrelType,nbytes)
6000         enddo
6001 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6002         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6003 cd      write (iout,*) 'Processor',MyID,
6004 cd   & ' has received correlation contribution from processor',MyID+1,
6005 cd   & ' msglen=',msglen,' nbytes=',nbytes
6006 cd      write (iout,*) 'The received BUFFER array:'
6007 cd      do i=1,max_cont
6008 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6009 cd      enddo
6010         if (msglen.eq.msglen1) then
6011           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6012         else if (msglen.eq.msglen2)  then
6013           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6014           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6015         else
6016           write (iout,*)
6017      & 'ERROR!!!! message length changed while processing correlations.'
6018           write (*,*)
6019      & 'ERROR!!!! message length changed while processing correlations.'
6020           call mp_stopall(Error)
6021         endif ! msglen.eq.msglen1
6022       endif ! MyRank.lt.fgProcs-1
6023       if (ldone) goto 30
6024       ldone=.true.
6025       goto 10
6026    30 continue
6027 #endif
6028       if (lprn) then
6029         write (iout,'(a)') 'Contact function values:'
6030         do i=nnt,nct-2
6031           write (iout,'(2i3,50(1x,i2,f5.2))')
6032      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6033      &    j=1,num_cont_hb(i))
6034         enddo
6035       endif
6036       ecorr=0.0D0
6037       ecorr5=0.0d0
6038       ecorr6=0.0d0
6039 C Remove the loop below after debugging !!!
6040       do i=nnt,nct
6041         do j=1,3
6042           gradcorr(j,i)=0.0D0
6043           gradxorr(j,i)=0.0D0
6044         enddo
6045       enddo
6046 C Calculate the dipole-dipole interaction energies
6047       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6048       do i=iatel_s,iatel_e+1
6049         num_conti=num_cont_hb(i)
6050         do jj=1,num_conti
6051           j=jcont_hb(jj,i)
6052           call dipole(i,j,jj)
6053         enddo
6054       enddo
6055       endif
6056 C Calculate the local-electrostatic correlation terms
6057       do i=iatel_s,iatel_e+1
6058         i1=i+1
6059         num_conti=num_cont_hb(i)
6060         num_conti1=num_cont_hb(i+1)
6061         do jj=1,num_conti
6062           j=jcont_hb(jj,i)
6063           do kk=1,num_conti1
6064             j1=jcont_hb(kk,i1)
6065 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6066 c     &         ' jj=',jj,' kk=',kk
6067             if (j1.eq.j+1 .or. j1.eq.j-1) then
6068 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6069 C The system gains extra energy.
6070               n_corr=n_corr+1
6071               sqd1=dsqrt(d_cont(jj,i))
6072               sqd2=dsqrt(d_cont(kk,i1))
6073               sred_geom = sqd1*sqd2
6074               IF (sred_geom.lt.cutoff_corr) THEN
6075                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6076      &            ekont,fprimcont)
6077 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6078 c     &         ' jj=',jj,' kk=',kk
6079                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6080                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6081                 do l=1,3
6082                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6083                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6084                 enddo
6085                 n_corr1=n_corr1+1
6086 cd               write (iout,*) 'sred_geom=',sred_geom,
6087 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6088                 call calc_eello(i,j,i+1,j1,jj,kk)
6089                 if (wcorr4.gt.0.0d0)
6090      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6091                 if (wcorr5.gt.0.0d0)
6092      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6093 c                print *,"wcorr5",ecorr5
6094 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6095 cd                write(2,*)'ijkl',i,j,i+1,j1
6096                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6097      &               .or. wturn6.eq.0.0d0))then
6098 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6099                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6100 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6101 cd     &            'ecorr6=',ecorr6
6102 cd                write (iout,'(4e15.5)') sred_geom,
6103 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6104 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6105 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6106                 else if (wturn6.gt.0.0d0
6107      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6108 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6109                   eturn6=eturn6+eello_turn6(i,jj,kk)
6110 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6111                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6112                    eturn6=0.0d0
6113                    ecorr6=0.0d0
6114                 endif
6115
6116               ENDIF
6117 1111          continue
6118             else if (j1.eq.j) then
6119 C Contacts I-J and I-(J+1) occur simultaneously.
6120 C The system loses extra energy.
6121 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6122             endif
6123           enddo ! kk
6124           do kk=1,num_conti
6125             j1=jcont_hb(kk,i)
6126 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6127 c    &         ' jj=',jj,' kk=',kk
6128             if (j1.eq.j+1) then
6129 C Contacts I-J and (I+1)-J occur simultaneously.
6130 C The system loses extra energy.
6131 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6132             endif ! j1==j+1
6133           enddo ! kk
6134         enddo ! jj
6135       enddo ! i
6136       write (iout,*) "eturn6",eturn6,ecorr6
6137       return
6138       end
6139 c------------------------------------------------------------------------------
6140       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6141       implicit real*8 (a-h,o-z)
6142       include 'DIMENSIONS'
6143       include 'COMMON.IOUNITS'
6144       include 'COMMON.DERIV'
6145       include 'COMMON.INTERACT'
6146       include 'COMMON.CONTACTS'
6147       include 'COMMON.CONTROL'
6148       include 'COMMON.SHIELD'
6149       double precision gx(3),gx1(3)
6150       logical lprn
6151       lprn=.false.
6152       eij=facont_hb(jj,i)
6153       ekl=facont_hb(kk,k)
6154       ees0pij=ees0p(jj,i)
6155       ees0pkl=ees0p(kk,k)
6156       ees0mij=ees0m(jj,i)
6157       ees0mkl=ees0m(kk,k)
6158       ekont=eij*ekl
6159       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6160 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6161 C Following 4 lines for diagnostics.
6162 cd    ees0pkl=0.0D0
6163 cd    ees0pij=1.0D0
6164 cd    ees0mkl=0.0D0
6165 cd    ees0mij=1.0D0
6166 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6167 c    &   ' and',k,l
6168 c     write (iout,*)'Contacts have occurred for peptide groups',
6169 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6170 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6171 C Calculate the multi-body contribution to energy.
6172 C      ecorr=ecorr+ekont*ees
6173       if (calc_grad) then
6174 C Calculate multi-body contributions to the gradient.
6175       do ll=1,3
6176         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6177         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6178      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6179      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6180         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6181      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6182      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6183         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6184         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6185      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6186      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6187         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6188      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6189      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6190       enddo
6191       do m=i+1,j-1
6192         do ll=1,3
6193           gradcorr(ll,m)=gradcorr(ll,m)+
6194      &     ees*ekl*gacont_hbr(ll,jj,i)-
6195      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6196      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6197         enddo
6198       enddo
6199       do m=k+1,l-1
6200         do ll=1,3
6201           gradcorr(ll,m)=gradcorr(ll,m)+
6202      &     ees*eij*gacont_hbr(ll,kk,k)-
6203      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6204      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6205         enddo
6206       enddo
6207       if (shield_mode.gt.0) then
6208        j=ees0plist(jj,i)
6209        l=ees0plist(kk,k)
6210 C        print *,i,j,fac_shield(i),fac_shield(j),
6211 C     &fac_shield(k),fac_shield(l)
6212         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6213      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6214           do ilist=1,ishield_list(i)
6215            iresshield=shield_list(ilist,i)
6216            do m=1,3
6217            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6218 C     &      *2.0
6219            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6220      &              rlocshield
6221      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6222             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6223      &+rlocshield
6224            enddo
6225           enddo
6226           do ilist=1,ishield_list(j)
6227            iresshield=shield_list(ilist,j)
6228            do m=1,3
6229            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6230 C     &     *2.0
6231            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6232      &              rlocshield
6233      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6234            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6235      &     +rlocshield
6236            enddo
6237           enddo
6238           do ilist=1,ishield_list(k)
6239            iresshield=shield_list(ilist,k)
6240            do m=1,3
6241            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6242 C     &     *2.0
6243            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6244      &              rlocshield
6245      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6246            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6247      &     +rlocshield
6248            enddo
6249           enddo
6250           do ilist=1,ishield_list(l)
6251            iresshield=shield_list(ilist,l)
6252            do m=1,3
6253            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6254 C     &     *2.0
6255            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6256      &              rlocshield
6257      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6258            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6259      &     +rlocshield
6260            enddo
6261           enddo
6262 C          print *,gshieldx(m,iresshield)
6263           do m=1,3
6264             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6265      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6266             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6267      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6268             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6269      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6270             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6271      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6272
6273             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6274      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6275             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6276      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6277             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6278      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6279             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6280      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6281
6282            enddo
6283       endif
6284       endif
6285       endif
6286       ehbcorr=ekont*ees
6287       return
6288       end
6289 C---------------------------------------------------------------------------
6290       subroutine dipole(i,j,jj)
6291       implicit real*8 (a-h,o-z)
6292       include 'DIMENSIONS'
6293       include 'DIMENSIONS.ZSCOPT'
6294       include 'COMMON.IOUNITS'
6295       include 'COMMON.CHAIN'
6296       include 'COMMON.FFIELD'
6297       include 'COMMON.DERIV'
6298       include 'COMMON.INTERACT'
6299       include 'COMMON.CONTACTS'
6300       include 'COMMON.TORSION'
6301       include 'COMMON.VAR'
6302       include 'COMMON.GEO'
6303       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6304      &  auxmat(2,2)
6305       iti1 = itortyp(itype(i+1))
6306       if (j.lt.nres-1) then
6307         if (itype(j).le.ntyp) then
6308           itj1 = itortyp(itype(j+1))
6309         else
6310           itj=ntortyp+1
6311         endif
6312       else
6313         itj1=ntortyp+1
6314       endif
6315       do iii=1,2
6316         dipi(iii,1)=Ub2(iii,i)
6317         dipderi(iii)=Ub2der(iii,i)
6318         dipi(iii,2)=b1(iii,iti1)
6319         dipj(iii,1)=Ub2(iii,j)
6320         dipderj(iii)=Ub2der(iii,j)
6321         dipj(iii,2)=b1(iii,itj1)
6322       enddo
6323       kkk=0
6324       do iii=1,2
6325         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6326         do jjj=1,2
6327           kkk=kkk+1
6328           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6329         enddo
6330       enddo
6331       if (.not.calc_grad) return
6332       do kkk=1,5
6333         do lll=1,3
6334           mmm=0
6335           do iii=1,2
6336             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6337      &        auxvec(1))
6338             do jjj=1,2
6339               mmm=mmm+1
6340               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6341             enddo
6342           enddo
6343         enddo
6344       enddo
6345       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6346       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6347       do iii=1,2
6348         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6349       enddo
6350       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6351       do iii=1,2
6352         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6353       enddo
6354       return
6355       end
6356 C---------------------------------------------------------------------------
6357       subroutine calc_eello(i,j,k,l,jj,kk)
6358 C
6359 C This subroutine computes matrices and vectors needed to calculate
6360 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6361 C
6362       implicit real*8 (a-h,o-z)
6363       include 'DIMENSIONS'
6364       include 'DIMENSIONS.ZSCOPT'
6365       include 'COMMON.IOUNITS'
6366       include 'COMMON.CHAIN'
6367       include 'COMMON.DERIV'
6368       include 'COMMON.INTERACT'
6369       include 'COMMON.CONTACTS'
6370       include 'COMMON.TORSION'
6371       include 'COMMON.VAR'
6372       include 'COMMON.GEO'
6373       include 'COMMON.FFIELD'
6374       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6375      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6376       logical lprn
6377       common /kutas/ lprn
6378 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6379 cd     & ' jj=',jj,' kk=',kk
6380 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6381       do iii=1,2
6382         do jjj=1,2
6383           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6384           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6385         enddo
6386       enddo
6387       call transpose2(aa1(1,1),aa1t(1,1))
6388       call transpose2(aa2(1,1),aa2t(1,1))
6389       do kkk=1,5
6390         do lll=1,3
6391           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6392      &      aa1tder(1,1,lll,kkk))
6393           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6394      &      aa2tder(1,1,lll,kkk))
6395         enddo
6396       enddo
6397       if (l.eq.j+1) then
6398 C parallel orientation of the two CA-CA-CA frames.
6399         if (i.gt.1 .and. itype(i).le.ntyp) then
6400           iti=itortyp(itype(i))
6401         else
6402           iti=ntortyp+1
6403         endif
6404         itk1=itortyp(itype(k+1))
6405         itj=itortyp(itype(j))
6406         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6407           itl1=itortyp(itype(l+1))
6408         else
6409           itl1=ntortyp+1
6410         endif
6411 C A1 kernel(j+1) A2T
6412 cd        do iii=1,2
6413 cd          write (iout,'(3f10.5,5x,3f10.5)')
6414 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6415 cd        enddo
6416         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6417      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6418      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6419 C Following matrices are needed only for 6-th order cumulants
6420         IF (wcorr6.gt.0.0d0) THEN
6421         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6422      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6423      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6424         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6425      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6426      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6427      &   ADtEAderx(1,1,1,1,1,1))
6428         lprn=.false.
6429         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6430      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6431      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6432      &   ADtEA1derx(1,1,1,1,1,1))
6433         ENDIF
6434 C End 6-th order cumulants
6435 cd        lprn=.false.
6436 cd        if (lprn) then
6437 cd        write (2,*) 'In calc_eello6'
6438 cd        do iii=1,2
6439 cd          write (2,*) 'iii=',iii
6440 cd          do kkk=1,5
6441 cd            write (2,*) 'kkk=',kkk
6442 cd            do jjj=1,2
6443 cd              write (2,'(3(2f10.5),5x)')
6444 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6445 cd            enddo
6446 cd          enddo
6447 cd        enddo
6448 cd        endif
6449         call transpose2(EUgder(1,1,k),auxmat(1,1))
6450         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6451         call transpose2(EUg(1,1,k),auxmat(1,1))
6452         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6453         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6454         do iii=1,2
6455           do kkk=1,5
6456             do lll=1,3
6457               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6458      &          EAEAderx(1,1,lll,kkk,iii,1))
6459             enddo
6460           enddo
6461         enddo
6462 C A1T kernel(i+1) A2
6463         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6464      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6465      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6466 C Following matrices are needed only for 6-th order cumulants
6467         IF (wcorr6.gt.0.0d0) THEN
6468         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6469      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6470      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6471         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6472      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6473      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6474      &   ADtEAderx(1,1,1,1,1,2))
6475         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6476      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6477      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6478      &   ADtEA1derx(1,1,1,1,1,2))
6479         ENDIF
6480 C End 6-th order cumulants
6481         call transpose2(EUgder(1,1,l),auxmat(1,1))
6482         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6483         call transpose2(EUg(1,1,l),auxmat(1,1))
6484         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6485         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6486         do iii=1,2
6487           do kkk=1,5
6488             do lll=1,3
6489               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6490      &          EAEAderx(1,1,lll,kkk,iii,2))
6491             enddo
6492           enddo
6493         enddo
6494 C AEAb1 and AEAb2
6495 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6496 C They are needed only when the fifth- or the sixth-order cumulants are
6497 C indluded.
6498         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6499         call transpose2(AEA(1,1,1),auxmat(1,1))
6500         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6501         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6502         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6503         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6504         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6505         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6506         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6507         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6508         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6509         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6510         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6511         call transpose2(AEA(1,1,2),auxmat(1,1))
6512         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6513         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6514         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6515         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6516         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6517         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6518         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6519         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6520         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6521         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6522         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6523 C Calculate the Cartesian derivatives of the vectors.
6524         do iii=1,2
6525           do kkk=1,5
6526             do lll=1,3
6527               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6528               call matvec2(auxmat(1,1),b1(1,iti),
6529      &          AEAb1derx(1,lll,kkk,iii,1,1))
6530               call matvec2(auxmat(1,1),Ub2(1,i),
6531      &          AEAb2derx(1,lll,kkk,iii,1,1))
6532               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6533      &          AEAb1derx(1,lll,kkk,iii,2,1))
6534               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6535      &          AEAb2derx(1,lll,kkk,iii,2,1))
6536               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6537               call matvec2(auxmat(1,1),b1(1,itj),
6538      &          AEAb1derx(1,lll,kkk,iii,1,2))
6539               call matvec2(auxmat(1,1),Ub2(1,j),
6540      &          AEAb2derx(1,lll,kkk,iii,1,2))
6541               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6542      &          AEAb1derx(1,lll,kkk,iii,2,2))
6543               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6544      &          AEAb2derx(1,lll,kkk,iii,2,2))
6545             enddo
6546           enddo
6547         enddo
6548         ENDIF
6549 C End vectors
6550       else
6551 C Antiparallel orientation of the two CA-CA-CA frames.
6552         if (i.gt.1 .and. itype(i).le.ntyp) then
6553           iti=itortyp(itype(i))
6554         else
6555           iti=ntortyp+1
6556         endif
6557         itk1=itortyp(itype(k+1))
6558         itl=itortyp(itype(l))
6559         itj=itortyp(itype(j))
6560         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6561           itj1=itortyp(itype(j+1))
6562         else
6563           itj1=ntortyp+1
6564         endif
6565 C A2 kernel(j-1)T A1T
6566         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6567      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6568      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6569 C Following matrices are needed only for 6-th order cumulants
6570         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6571      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6572         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6573      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6574      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6575         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6576      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6577      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6578      &   ADtEAderx(1,1,1,1,1,1))
6579         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6580      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6581      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6582      &   ADtEA1derx(1,1,1,1,1,1))
6583         ENDIF
6584 C End 6-th order cumulants
6585         call transpose2(EUgder(1,1,k),auxmat(1,1))
6586         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6587         call transpose2(EUg(1,1,k),auxmat(1,1))
6588         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6589         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6590         do iii=1,2
6591           do kkk=1,5
6592             do lll=1,3
6593               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6594      &          EAEAderx(1,1,lll,kkk,iii,1))
6595             enddo
6596           enddo
6597         enddo
6598 C A2T kernel(i+1)T A1
6599         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6600      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6601      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6602 C Following matrices are needed only for 6-th order cumulants
6603         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6604      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6605         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6606      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6607      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6608         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6609      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6610      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6611      &   ADtEAderx(1,1,1,1,1,2))
6612         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6613      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6614      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6615      &   ADtEA1derx(1,1,1,1,1,2))
6616         ENDIF
6617 C End 6-th order cumulants
6618         call transpose2(EUgder(1,1,j),auxmat(1,1))
6619         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6620         call transpose2(EUg(1,1,j),auxmat(1,1))
6621         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6622         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6623         do iii=1,2
6624           do kkk=1,5
6625             do lll=1,3
6626               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6627      &          EAEAderx(1,1,lll,kkk,iii,2))
6628             enddo
6629           enddo
6630         enddo
6631 C AEAb1 and AEAb2
6632 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6633 C They are needed only when the fifth- or the sixth-order cumulants are
6634 C indluded.
6635         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6636      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6637         call transpose2(AEA(1,1,1),auxmat(1,1))
6638         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6639         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6640         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6641         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6642         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6643         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6644         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6645         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6646         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6647         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6648         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6649         call transpose2(AEA(1,1,2),auxmat(1,1))
6650         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6651         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6652         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6653         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6654         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6655         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6656         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6657         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6658         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6659         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6660         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6661 C Calculate the Cartesian derivatives of the vectors.
6662         do iii=1,2
6663           do kkk=1,5
6664             do lll=1,3
6665               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6666               call matvec2(auxmat(1,1),b1(1,iti),
6667      &          AEAb1derx(1,lll,kkk,iii,1,1))
6668               call matvec2(auxmat(1,1),Ub2(1,i),
6669      &          AEAb2derx(1,lll,kkk,iii,1,1))
6670               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6671      &          AEAb1derx(1,lll,kkk,iii,2,1))
6672               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6673      &          AEAb2derx(1,lll,kkk,iii,2,1))
6674               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6675               call matvec2(auxmat(1,1),b1(1,itl),
6676      &          AEAb1derx(1,lll,kkk,iii,1,2))
6677               call matvec2(auxmat(1,1),Ub2(1,l),
6678      &          AEAb2derx(1,lll,kkk,iii,1,2))
6679               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6680      &          AEAb1derx(1,lll,kkk,iii,2,2))
6681               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6682      &          AEAb2derx(1,lll,kkk,iii,2,2))
6683             enddo
6684           enddo
6685         enddo
6686         ENDIF
6687 C End vectors
6688       endif
6689       return
6690       end
6691 C---------------------------------------------------------------------------
6692       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6693      &  KK,KKderg,AKA,AKAderg,AKAderx)
6694       implicit none
6695       integer nderg
6696       logical transp
6697       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6698      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6699      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6700       integer iii,kkk,lll
6701       integer jjj,mmm
6702       logical lprn
6703       common /kutas/ lprn
6704       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6705       do iii=1,nderg
6706         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6707      &    AKAderg(1,1,iii))
6708       enddo
6709 cd      if (lprn) write (2,*) 'In kernel'
6710       do kkk=1,5
6711 cd        if (lprn) write (2,*) 'kkk=',kkk
6712         do lll=1,3
6713           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6714      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6715 cd          if (lprn) then
6716 cd            write (2,*) 'lll=',lll
6717 cd            write (2,*) 'iii=1'
6718 cd            do jjj=1,2
6719 cd              write (2,'(3(2f10.5),5x)')
6720 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6721 cd            enddo
6722 cd          endif
6723           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6724      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6725 cd          if (lprn) then
6726 cd            write (2,*) 'lll=',lll
6727 cd            write (2,*) 'iii=2'
6728 cd            do jjj=1,2
6729 cd              write (2,'(3(2f10.5),5x)')
6730 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6731 cd            enddo
6732 cd          endif
6733         enddo
6734       enddo
6735       return
6736       end
6737 C---------------------------------------------------------------------------
6738       double precision function eello4(i,j,k,l,jj,kk)
6739       implicit real*8 (a-h,o-z)
6740       include 'DIMENSIONS'
6741       include 'DIMENSIONS.ZSCOPT'
6742       include 'COMMON.IOUNITS'
6743       include 'COMMON.CHAIN'
6744       include 'COMMON.DERIV'
6745       include 'COMMON.INTERACT'
6746       include 'COMMON.CONTACTS'
6747       include 'COMMON.TORSION'
6748       include 'COMMON.VAR'
6749       include 'COMMON.GEO'
6750       double precision pizda(2,2),ggg1(3),ggg2(3)
6751 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6752 cd        eello4=0.0d0
6753 cd        return
6754 cd      endif
6755 cd      print *,'eello4:',i,j,k,l,jj,kk
6756 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6757 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6758 cold      eij=facont_hb(jj,i)
6759 cold      ekl=facont_hb(kk,k)
6760 cold      ekont=eij*ekl
6761       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6762       if (calc_grad) then
6763 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6764       gcorr_loc(k-1)=gcorr_loc(k-1)
6765      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6766       if (l.eq.j+1) then
6767         gcorr_loc(l-1)=gcorr_loc(l-1)
6768      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6769       else
6770         gcorr_loc(j-1)=gcorr_loc(j-1)
6771      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6772       endif
6773       do iii=1,2
6774         do kkk=1,5
6775           do lll=1,3
6776             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6777      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6778 cd            derx(lll,kkk,iii)=0.0d0
6779           enddo
6780         enddo
6781       enddo
6782 cd      gcorr_loc(l-1)=0.0d0
6783 cd      gcorr_loc(j-1)=0.0d0
6784 cd      gcorr_loc(k-1)=0.0d0
6785 cd      eel4=1.0d0
6786 cd      write (iout,*)'Contacts have occurred for peptide groups',
6787 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6788 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6789       if (j.lt.nres-1) then
6790         j1=j+1
6791         j2=j-1
6792       else
6793         j1=j-1
6794         j2=j-2
6795       endif
6796       if (l.lt.nres-1) then
6797         l1=l+1
6798         l2=l-1
6799       else
6800         l1=l-1
6801         l2=l-2
6802       endif
6803       do ll=1,3
6804 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6805         ggg1(ll)=eel4*g_contij(ll,1)
6806         ggg2(ll)=eel4*g_contij(ll,2)
6807         ghalf=0.5d0*ggg1(ll)
6808 cd        ghalf=0.0d0
6809         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6810         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6811         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6812         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6813 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6814         ghalf=0.5d0*ggg2(ll)
6815 cd        ghalf=0.0d0
6816         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6817         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6818         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6819         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6820       enddo
6821 cd      goto 1112
6822       do m=i+1,j-1
6823         do ll=1,3
6824 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6825           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6826         enddo
6827       enddo
6828       do m=k+1,l-1
6829         do ll=1,3
6830 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6831           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6832         enddo
6833       enddo
6834 1112  continue
6835       do m=i+2,j2
6836         do ll=1,3
6837           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6838         enddo
6839       enddo
6840       do m=k+2,l2
6841         do ll=1,3
6842           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6843         enddo
6844       enddo
6845 cd      do iii=1,nres-3
6846 cd        write (2,*) iii,gcorr_loc(iii)
6847 cd      enddo
6848       endif
6849       eello4=ekont*eel4
6850 cd      write (2,*) 'ekont',ekont
6851 cd      write (iout,*) 'eello4',ekont*eel4
6852       return
6853       end
6854 C---------------------------------------------------------------------------
6855       double precision function eello5(i,j,k,l,jj,kk)
6856       implicit real*8 (a-h,o-z)
6857       include 'DIMENSIONS'
6858       include 'DIMENSIONS.ZSCOPT'
6859       include 'COMMON.IOUNITS'
6860       include 'COMMON.CHAIN'
6861       include 'COMMON.DERIV'
6862       include 'COMMON.INTERACT'
6863       include 'COMMON.CONTACTS'
6864       include 'COMMON.TORSION'
6865       include 'COMMON.VAR'
6866       include 'COMMON.GEO'
6867       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6868       double precision ggg1(3),ggg2(3)
6869 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6870 C                                                                              C
6871 C                            Parallel chains                                   C
6872 C                                                                              C
6873 C          o             o                   o             o                   C
6874 C         /l\           / \             \   / \           / \   /              C
6875 C        /   \         /   \             \ /   \         /   \ /               C
6876 C       j| o |l1       | o |              o| o |         | o |o                C
6877 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6878 C      \i/   \         /   \ /             /   \         /   \                 C
6879 C       o    k1             o                                                  C
6880 C         (I)          (II)                (III)          (IV)                 C
6881 C                                                                              C
6882 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6883 C                                                                              C
6884 C                            Antiparallel chains                               C
6885 C                                                                              C
6886 C          o             o                   o             o                   C
6887 C         /j\           / \             \   / \           / \   /              C
6888 C        /   \         /   \             \ /   \         /   \ /               C
6889 C      j1| o |l        | o |              o| o |         | o |o                C
6890 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6891 C      \i/   \         /   \ /             /   \         /   \                 C
6892 C       o     k1            o                                                  C
6893 C         (I)          (II)                (III)          (IV)                 C
6894 C                                                                              C
6895 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6896 C                                                                              C
6897 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6898 C                                                                              C
6899 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6900 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6901 cd        eello5=0.0d0
6902 cd        return
6903 cd      endif
6904 cd      write (iout,*)
6905 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6906 cd     &   ' and',k,l
6907       itk=itortyp(itype(k))
6908       itl=itortyp(itype(l))
6909       itj=itortyp(itype(j))
6910       eello5_1=0.0d0
6911       eello5_2=0.0d0
6912       eello5_3=0.0d0
6913       eello5_4=0.0d0
6914 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6915 cd     &   eel5_3_num,eel5_4_num)
6916       do iii=1,2
6917         do kkk=1,5
6918           do lll=1,3
6919             derx(lll,kkk,iii)=0.0d0
6920           enddo
6921         enddo
6922       enddo
6923 cd      eij=facont_hb(jj,i)
6924 cd      ekl=facont_hb(kk,k)
6925 cd      ekont=eij*ekl
6926 cd      write (iout,*)'Contacts have occurred for peptide groups',
6927 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6928 cd      goto 1111
6929 C Contribution from the graph I.
6930 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6931 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6932       call transpose2(EUg(1,1,k),auxmat(1,1))
6933       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6934       vv(1)=pizda(1,1)-pizda(2,2)
6935       vv(2)=pizda(1,2)+pizda(2,1)
6936       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6937      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6938       if (calc_grad) then
6939 C Explicit gradient in virtual-dihedral angles.
6940       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6941      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6942      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6943       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6944       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6945       vv(1)=pizda(1,1)-pizda(2,2)
6946       vv(2)=pizda(1,2)+pizda(2,1)
6947       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6948      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6949      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6950       call matmat2(AEAderg(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       if (l.eq.j+1) then
6954         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6955      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6956      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6957       else
6958         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6959      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6960      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6961       endif
6962 C Cartesian gradient
6963       do iii=1,2
6964         do kkk=1,5
6965           do lll=1,3
6966             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6967      &        pizda(1,1))
6968             vv(1)=pizda(1,1)-pizda(2,2)
6969             vv(2)=pizda(1,2)+pizda(2,1)
6970             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6971      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6972      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6973           enddo
6974         enddo
6975       enddo
6976 c      goto 1112
6977       endif
6978 c1111  continue
6979 C Contribution from graph II
6980       call transpose2(EE(1,1,itk),auxmat(1,1))
6981       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6982       vv(1)=pizda(1,1)+pizda(2,2)
6983       vv(2)=pizda(2,1)-pizda(1,2)
6984       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6985      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6986       if (calc_grad) then
6987 C Explicit gradient in virtual-dihedral angles.
6988       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6989      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6990       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6991       vv(1)=pizda(1,1)+pizda(2,2)
6992       vv(2)=pizda(2,1)-pizda(1,2)
6993       if (l.eq.j+1) then
6994         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6995      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6996      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6997       else
6998         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6999      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7000      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7001       endif
7002 C Cartesian gradient
7003       do iii=1,2
7004         do kkk=1,5
7005           do lll=1,3
7006             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7007      &        pizda(1,1))
7008             vv(1)=pizda(1,1)+pizda(2,2)
7009             vv(2)=pizda(2,1)-pizda(1,2)
7010             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7011      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7012      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7013           enddo
7014         enddo
7015       enddo
7016 cd      goto 1112
7017       endif
7018 cd1111  continue
7019       if (l.eq.j+1) then
7020 cd        goto 1110
7021 C Parallel orientation
7022 C Contribution from graph III
7023         call transpose2(EUg(1,1,l),auxmat(1,1))
7024         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7025         vv(1)=pizda(1,1)-pizda(2,2)
7026         vv(2)=pizda(1,2)+pizda(2,1)
7027         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7028      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7029         if (calc_grad) then
7030 C Explicit gradient in virtual-dihedral angles.
7031         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7032      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7033      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7034         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7035         vv(1)=pizda(1,1)-pizda(2,2)
7036         vv(2)=pizda(1,2)+pizda(2,1)
7037         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7038      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7039      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7040         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7041         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7042         vv(1)=pizda(1,1)-pizda(2,2)
7043         vv(2)=pizda(1,2)+pizda(2,1)
7044         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7045      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7046      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7047 C Cartesian gradient
7048         do iii=1,2
7049           do kkk=1,5
7050             do lll=1,3
7051               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7052      &          pizda(1,1))
7053               vv(1)=pizda(1,1)-pizda(2,2)
7054               vv(2)=pizda(1,2)+pizda(2,1)
7055               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7056      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7057      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7058             enddo
7059           enddo
7060         enddo
7061 cd        goto 1112
7062         endif
7063 C Contribution from graph IV
7064 cd1110    continue
7065         call transpose2(EE(1,1,itl),auxmat(1,1))
7066         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7067         vv(1)=pizda(1,1)+pizda(2,2)
7068         vv(2)=pizda(2,1)-pizda(1,2)
7069         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7070      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7071         if (calc_grad) then
7072 C Explicit gradient in virtual-dihedral angles.
7073         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7074      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7075         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7076         vv(1)=pizda(1,1)+pizda(2,2)
7077         vv(2)=pizda(2,1)-pizda(1,2)
7078         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7079      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7080      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7081 C Cartesian gradient
7082         do iii=1,2
7083           do kkk=1,5
7084             do lll=1,3
7085               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7086      &          pizda(1,1))
7087               vv(1)=pizda(1,1)+pizda(2,2)
7088               vv(2)=pizda(2,1)-pizda(1,2)
7089               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7090      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7091      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7092             enddo
7093           enddo
7094         enddo
7095         endif
7096       else
7097 C Antiparallel orientation
7098 C Contribution from graph III
7099 c        goto 1110
7100         call transpose2(EUg(1,1,j),auxmat(1,1))
7101         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7102         vv(1)=pizda(1,1)-pizda(2,2)
7103         vv(2)=pizda(1,2)+pizda(2,1)
7104         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7105      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7106         if (calc_grad) then
7107 C Explicit gradient in virtual-dihedral angles.
7108         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7109      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7110      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7111         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7112         vv(1)=pizda(1,1)-pizda(2,2)
7113         vv(2)=pizda(1,2)+pizda(2,1)
7114         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7115      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7116      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7117         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7118         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7119         vv(1)=pizda(1,1)-pizda(2,2)
7120         vv(2)=pizda(1,2)+pizda(2,1)
7121         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7122      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7123      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7124 C Cartesian gradient
7125         do iii=1,2
7126           do kkk=1,5
7127             do lll=1,3
7128               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7129      &          pizda(1,1))
7130               vv(1)=pizda(1,1)-pizda(2,2)
7131               vv(2)=pizda(1,2)+pizda(2,1)
7132               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7133      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7134      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7135             enddo
7136           enddo
7137         enddo
7138 cd        goto 1112
7139         endif
7140 C Contribution from graph IV
7141 1110    continue
7142         call transpose2(EE(1,1,itj),auxmat(1,1))
7143         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7144         vv(1)=pizda(1,1)+pizda(2,2)
7145         vv(2)=pizda(2,1)-pizda(1,2)
7146         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7147      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7148         if (calc_grad) then
7149 C Explicit gradient in virtual-dihedral angles.
7150         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7151      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7152         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7153         vv(1)=pizda(1,1)+pizda(2,2)
7154         vv(2)=pizda(2,1)-pizda(1,2)
7155         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7156      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7157      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7158 C Cartesian gradient
7159         do iii=1,2
7160           do kkk=1,5
7161             do lll=1,3
7162               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7163      &          pizda(1,1))
7164               vv(1)=pizda(1,1)+pizda(2,2)
7165               vv(2)=pizda(2,1)-pizda(1,2)
7166               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7167      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7168      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7169             enddo
7170           enddo
7171         enddo
7172       endif
7173       endif
7174 1112  continue
7175       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7176 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7177 cd        write (2,*) 'ijkl',i,j,k,l
7178 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7179 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7180 cd      endif
7181 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7182 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7183 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7184 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7185       if (calc_grad) then
7186       if (j.lt.nres-1) then
7187         j1=j+1
7188         j2=j-1
7189       else
7190         j1=j-1
7191         j2=j-2
7192       endif
7193       if (l.lt.nres-1) then
7194         l1=l+1
7195         l2=l-1
7196       else
7197         l1=l-1
7198         l2=l-2
7199       endif
7200 cd      eij=1.0d0
7201 cd      ekl=1.0d0
7202 cd      ekont=1.0d0
7203 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7204       do ll=1,3
7205         ggg1(ll)=eel5*g_contij(ll,1)
7206         ggg2(ll)=eel5*g_contij(ll,2)
7207 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7208         ghalf=0.5d0*ggg1(ll)
7209 cd        ghalf=0.0d0
7210         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7211         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7212         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7213         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7214 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7215         ghalf=0.5d0*ggg2(ll)
7216 cd        ghalf=0.0d0
7217         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7218         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7219         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7220         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7221       enddo
7222 cd      goto 1112
7223       do m=i+1,j-1
7224         do ll=1,3
7225 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7226           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7227         enddo
7228       enddo
7229       do m=k+1,l-1
7230         do ll=1,3
7231 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7232           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7233         enddo
7234       enddo
7235 c1112  continue
7236       do m=i+2,j2
7237         do ll=1,3
7238           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7239         enddo
7240       enddo
7241       do m=k+2,l2
7242         do ll=1,3
7243           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7244         enddo
7245       enddo
7246 cd      do iii=1,nres-3
7247 cd        write (2,*) iii,g_corr5_loc(iii)
7248 cd      enddo
7249       endif
7250       eello5=ekont*eel5
7251 cd      write (2,*) 'ekont',ekont
7252 cd      write (iout,*) 'eello5',ekont*eel5
7253       return
7254       end
7255 c--------------------------------------------------------------------------
7256       double precision function eello6(i,j,k,l,jj,kk)
7257       implicit real*8 (a-h,o-z)
7258       include 'DIMENSIONS'
7259       include 'DIMENSIONS.ZSCOPT'
7260       include 'COMMON.IOUNITS'
7261       include 'COMMON.CHAIN'
7262       include 'COMMON.DERIV'
7263       include 'COMMON.INTERACT'
7264       include 'COMMON.CONTACTS'
7265       include 'COMMON.TORSION'
7266       include 'COMMON.VAR'
7267       include 'COMMON.GEO'
7268       include 'COMMON.FFIELD'
7269       double precision ggg1(3),ggg2(3)
7270 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7271 cd        eello6=0.0d0
7272 cd        return
7273 cd      endif
7274 cd      write (iout,*)
7275 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7276 cd     &   ' and',k,l
7277       eello6_1=0.0d0
7278       eello6_2=0.0d0
7279       eello6_3=0.0d0
7280       eello6_4=0.0d0
7281       eello6_5=0.0d0
7282       eello6_6=0.0d0
7283 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7284 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7285       do iii=1,2
7286         do kkk=1,5
7287           do lll=1,3
7288             derx(lll,kkk,iii)=0.0d0
7289           enddo
7290         enddo
7291       enddo
7292 cd      eij=facont_hb(jj,i)
7293 cd      ekl=facont_hb(kk,k)
7294 cd      ekont=eij*ekl
7295 cd      eij=1.0d0
7296 cd      ekl=1.0d0
7297 cd      ekont=1.0d0
7298       if (l.eq.j+1) then
7299         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7300         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7301         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7302         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7303         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7304         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7305       else
7306         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7307         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7308         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7309         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7310         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7311           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7312         else
7313           eello6_5=0.0d0
7314         endif
7315         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7316       endif
7317 C If turn contributions are considered, they will be handled separately.
7318       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7319 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7320 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7321 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7322 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7323 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7324 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7325 cd      goto 1112
7326       if (calc_grad) then
7327       if (j.lt.nres-1) then
7328         j1=j+1
7329         j2=j-1
7330       else
7331         j1=j-1
7332         j2=j-2
7333       endif
7334       if (l.lt.nres-1) then
7335         l1=l+1
7336         l2=l-1
7337       else
7338         l1=l-1
7339         l2=l-2
7340       endif
7341       do ll=1,3
7342         ggg1(ll)=eel6*g_contij(ll,1)
7343         ggg2(ll)=eel6*g_contij(ll,2)
7344 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7345         ghalf=0.5d0*ggg1(ll)
7346 cd        ghalf=0.0d0
7347         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7348         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7349         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7350         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7351         ghalf=0.5d0*ggg2(ll)
7352 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7353 cd        ghalf=0.0d0
7354         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7355         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7356         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7357         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7358       enddo
7359 cd      goto 1112
7360       do m=i+1,j-1
7361         do ll=1,3
7362 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7363           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7364         enddo
7365       enddo
7366       do m=k+1,l-1
7367         do ll=1,3
7368 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7369           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7370         enddo
7371       enddo
7372 1112  continue
7373       do m=i+2,j2
7374         do ll=1,3
7375           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7376         enddo
7377       enddo
7378       do m=k+2,l2
7379         do ll=1,3
7380           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7381         enddo
7382       enddo
7383 cd      do iii=1,nres-3
7384 cd        write (2,*) iii,g_corr6_loc(iii)
7385 cd      enddo
7386       endif
7387       eello6=ekont*eel6
7388 cd      write (2,*) 'ekont',ekont
7389 cd      write (iout,*) 'eello6',ekont*eel6
7390       return
7391       end
7392 c--------------------------------------------------------------------------
7393       double precision function eello6_graph1(i,j,k,l,imat,swap)
7394       implicit real*8 (a-h,o-z)
7395       include 'DIMENSIONS'
7396       include 'DIMENSIONS.ZSCOPT'
7397       include 'COMMON.IOUNITS'
7398       include 'COMMON.CHAIN'
7399       include 'COMMON.DERIV'
7400       include 'COMMON.INTERACT'
7401       include 'COMMON.CONTACTS'
7402       include 'COMMON.TORSION'
7403       include 'COMMON.VAR'
7404       include 'COMMON.GEO'
7405       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7406       logical swap
7407       logical lprn
7408       common /kutas/ lprn
7409 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7410 C                                                                              C
7411 C      Parallel       Antiparallel                                             C
7412 C                                                                              C
7413 C          o             o                                                     C
7414 C         /l\           /j\                                                    C
7415 C        /   \         /   \                                                   C
7416 C       /| o |         | o |\                                                  C
7417 C     \ j|/k\|  /   \  |/k\|l /                                                C
7418 C      \ /   \ /     \ /   \ /                                                 C
7419 C       o     o       o     o                                                  C
7420 C       i             i                                                        C
7421 C                                                                              C
7422 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7423       itk=itortyp(itype(k))
7424       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7425       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7426       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7427       call transpose2(EUgC(1,1,k),auxmat(1,1))
7428       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7429       vv1(1)=pizda1(1,1)-pizda1(2,2)
7430       vv1(2)=pizda1(1,2)+pizda1(2,1)
7431       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7432       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7433       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7434       s5=scalar2(vv(1),Dtobr2(1,i))
7435 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7436       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7437       if (.not. calc_grad) return
7438       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7439      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7440      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7441      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7442      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7443      & +scalar2(vv(1),Dtobr2der(1,i)))
7444       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7445       vv1(1)=pizda1(1,1)-pizda1(2,2)
7446       vv1(2)=pizda1(1,2)+pizda1(2,1)
7447       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7448       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7449       if (l.eq.j+1) then
7450         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7451      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7452      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7453      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7454      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7455       else
7456         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7457      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7458      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7459      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7460      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7461       endif
7462       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7463       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7464       vv1(1)=pizda1(1,1)-pizda1(2,2)
7465       vv1(2)=pizda1(1,2)+pizda1(2,1)
7466       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7467      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7468      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7469      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7470       do iii=1,2
7471         if (swap) then
7472           ind=3-iii
7473         else
7474           ind=iii
7475         endif
7476         do kkk=1,5
7477           do lll=1,3
7478             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7479             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7480             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7481             call transpose2(EUgC(1,1,k),auxmat(1,1))
7482             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7483      &        pizda1(1,1))
7484             vv1(1)=pizda1(1,1)-pizda1(2,2)
7485             vv1(2)=pizda1(1,2)+pizda1(2,1)
7486             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7487             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7488      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7489             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7490      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7491             s5=scalar2(vv(1),Dtobr2(1,i))
7492             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7493           enddo
7494         enddo
7495       enddo
7496       return
7497       end
7498 c----------------------------------------------------------------------------
7499       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7500       implicit real*8 (a-h,o-z)
7501       include 'DIMENSIONS'
7502       include 'DIMENSIONS.ZSCOPT'
7503       include 'COMMON.IOUNITS'
7504       include 'COMMON.CHAIN'
7505       include 'COMMON.DERIV'
7506       include 'COMMON.INTERACT'
7507       include 'COMMON.CONTACTS'
7508       include 'COMMON.TORSION'
7509       include 'COMMON.VAR'
7510       include 'COMMON.GEO'
7511       logical swap
7512       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7513      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7514       logical lprn
7515       common /kutas/ lprn
7516 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7517 C                                                                              C
7518 C      Parallel       Antiparallel                                             C
7519 C                                                                              C
7520 C          o             o                                                     C
7521 C     \   /l\           /j\   /                                                C
7522 C      \ /   \         /   \ /                                                 C
7523 C       o| o |         | o |o                                                  C
7524 C     \ j|/k\|      \  |/k\|l                                                  C
7525 C      \ /   \       \ /   \                                                   C
7526 C       o             o                                                        C
7527 C       i             i                                                        C
7528 C                                                                              C
7529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7530 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7531 C AL 7/4/01 s1 would occur in the sixth-order moment,
7532 C           but not in a cluster cumulant
7533 #ifdef MOMENT
7534       s1=dip(1,jj,i)*dip(1,kk,k)
7535 #endif
7536       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7537       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7538       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7539       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7540       call transpose2(EUg(1,1,k),auxmat(1,1))
7541       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7542       vv(1)=pizda(1,1)-pizda(2,2)
7543       vv(2)=pizda(1,2)+pizda(2,1)
7544       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7545 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7546 #ifdef MOMENT
7547       eello6_graph2=-(s1+s2+s3+s4)
7548 #else
7549       eello6_graph2=-(s2+s3+s4)
7550 #endif
7551 c      eello6_graph2=-s3
7552       if (.not. calc_grad) return
7553 C Derivatives in gamma(i-1)
7554       if (i.gt.1) then
7555 #ifdef MOMENT
7556         s1=dipderg(1,jj,i)*dip(1,kk,k)
7557 #endif
7558         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7559         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7560         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7561         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7562 #ifdef MOMENT
7563         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7564 #else
7565         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7566 #endif
7567 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7568       endif
7569 C Derivatives in gamma(k-1)
7570 #ifdef MOMENT
7571       s1=dip(1,jj,i)*dipderg(1,kk,k)
7572 #endif
7573       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7574       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7575       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7576       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7577       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7578       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7579       vv(1)=pizda(1,1)-pizda(2,2)
7580       vv(2)=pizda(1,2)+pizda(2,1)
7581       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7582 #ifdef MOMENT
7583       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7584 #else
7585       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7586 #endif
7587 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7588 C Derivatives in gamma(j-1) or gamma(l-1)
7589       if (j.gt.1) then
7590 #ifdef MOMENT
7591         s1=dipderg(3,jj,i)*dip(1,kk,k)
7592 #endif
7593         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7594         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7595         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7596         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7597         vv(1)=pizda(1,1)-pizda(2,2)
7598         vv(2)=pizda(1,2)+pizda(2,1)
7599         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7600 #ifdef MOMENT
7601         if (swap) then
7602           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7603         else
7604           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7605         endif
7606 #endif
7607         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7608 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7609       endif
7610 C Derivatives in gamma(l-1) or gamma(j-1)
7611       if (l.gt.1) then
7612 #ifdef MOMENT
7613         s1=dip(1,jj,i)*dipderg(3,kk,k)
7614 #endif
7615         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7616         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7617         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7618         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7619         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7620         vv(1)=pizda(1,1)-pizda(2,2)
7621         vv(2)=pizda(1,2)+pizda(2,1)
7622         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7623 #ifdef MOMENT
7624         if (swap) then
7625           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7626         else
7627           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7628         endif
7629 #endif
7630         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7631 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7632       endif
7633 C Cartesian derivatives.
7634       if (lprn) then
7635         write (2,*) 'In eello6_graph2'
7636         do iii=1,2
7637           write (2,*) 'iii=',iii
7638           do kkk=1,5
7639             write (2,*) 'kkk=',kkk
7640             do jjj=1,2
7641               write (2,'(3(2f10.5),5x)')
7642      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7643             enddo
7644           enddo
7645         enddo
7646       endif
7647       do iii=1,2
7648         do kkk=1,5
7649           do lll=1,3
7650 #ifdef MOMENT
7651             if (iii.eq.1) then
7652               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7653             else
7654               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7655             endif
7656 #endif
7657             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7658      &        auxvec(1))
7659             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7660             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7661      &        auxvec(1))
7662             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7663             call transpose2(EUg(1,1,k),auxmat(1,1))
7664             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7665      &        pizda(1,1))
7666             vv(1)=pizda(1,1)-pizda(2,2)
7667             vv(2)=pizda(1,2)+pizda(2,1)
7668             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7669 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7670 #ifdef MOMENT
7671             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7672 #else
7673             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7674 #endif
7675             if (swap) then
7676               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7677             else
7678               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7679             endif
7680           enddo
7681         enddo
7682       enddo
7683       return
7684       end
7685 c----------------------------------------------------------------------------
7686       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7687       implicit real*8 (a-h,o-z)
7688       include 'DIMENSIONS'
7689       include 'DIMENSIONS.ZSCOPT'
7690       include 'COMMON.IOUNITS'
7691       include 'COMMON.CHAIN'
7692       include 'COMMON.DERIV'
7693       include 'COMMON.INTERACT'
7694       include 'COMMON.CONTACTS'
7695       include 'COMMON.TORSION'
7696       include 'COMMON.VAR'
7697       include 'COMMON.GEO'
7698       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7699       logical swap
7700 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7701 C                                                                              C
7702 C      Parallel       Antiparallel                                             C
7703 C                                                                              C
7704 C          o             o                                                     C
7705 C         /l\   /   \   /j\                                                    C
7706 C        /   \ /     \ /   \                                                   C
7707 C       /| o |o       o| o |\                                                  C
7708 C       j|/k\|  /      |/k\|l /                                                C
7709 C        /   \ /       /   \ /                                                 C
7710 C       /     o       /     o                                                  C
7711 C       i             i                                                        C
7712 C                                                                              C
7713 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7714 C
7715 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7716 C           energy moment and not to the cluster cumulant.
7717       iti=itortyp(itype(i))
7718       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7719         itj1=itortyp(itype(j+1))
7720       else
7721         itj1=ntortyp+1
7722       endif
7723       itk=itortyp(itype(k))
7724       itk1=itortyp(itype(k+1))
7725       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7726         itl1=itortyp(itype(l+1))
7727       else
7728         itl1=ntortyp+1
7729       endif
7730 #ifdef MOMENT
7731       s1=dip(4,jj,i)*dip(4,kk,k)
7732 #endif
7733       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7734       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7735       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7736       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7737       call transpose2(EE(1,1,itk),auxmat(1,1))
7738       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7739       vv(1)=pizda(1,1)+pizda(2,2)
7740       vv(2)=pizda(2,1)-pizda(1,2)
7741       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7742 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7743 #ifdef MOMENT
7744       eello6_graph3=-(s1+s2+s3+s4)
7745 #else
7746       eello6_graph3=-(s2+s3+s4)
7747 #endif
7748 c      eello6_graph3=-s4
7749       if (.not. calc_grad) return
7750 C Derivatives in gamma(k-1)
7751       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7752       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7753       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7754       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7755 C Derivatives in gamma(l-1)
7756       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7757       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7758       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7759       vv(1)=pizda(1,1)+pizda(2,2)
7760       vv(2)=pizda(2,1)-pizda(1,2)
7761       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7762       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7763 C Cartesian derivatives.
7764       do iii=1,2
7765         do kkk=1,5
7766           do lll=1,3
7767 #ifdef MOMENT
7768             if (iii.eq.1) then
7769               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7770             else
7771               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7772             endif
7773 #endif
7774             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7775      &        auxvec(1))
7776             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7777             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7778      &        auxvec(1))
7779             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7780             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7781      &        pizda(1,1))
7782             vv(1)=pizda(1,1)+pizda(2,2)
7783             vv(2)=pizda(2,1)-pizda(1,2)
7784             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7785 #ifdef MOMENT
7786             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7787 #else
7788             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7789 #endif
7790             if (swap) then
7791               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7792             else
7793               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7794             endif
7795 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7796           enddo
7797         enddo
7798       enddo
7799       return
7800       end
7801 c----------------------------------------------------------------------------
7802       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7803       implicit real*8 (a-h,o-z)
7804       include 'DIMENSIONS'
7805       include 'DIMENSIONS.ZSCOPT'
7806       include 'COMMON.IOUNITS'
7807       include 'COMMON.CHAIN'
7808       include 'COMMON.DERIV'
7809       include 'COMMON.INTERACT'
7810       include 'COMMON.CONTACTS'
7811       include 'COMMON.TORSION'
7812       include 'COMMON.VAR'
7813       include 'COMMON.GEO'
7814       include 'COMMON.FFIELD'
7815       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7816      & auxvec1(2),auxmat1(2,2)
7817       logical swap
7818 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7819 C                                                                              C
7820 C      Parallel       Antiparallel                                             C
7821 C                                                                              C
7822 C          o             o                                                     C
7823 C         /l\   /   \   /j\                                                    C
7824 C        /   \ /     \ /   \                                                   C
7825 C       /| o |o       o| o |\                                                  C
7826 C     \ j|/k\|      \  |/k\|l                                                  C
7827 C      \ /   \       \ /   \                                                   C
7828 C       o     \       o     \                                                  C
7829 C       i             i                                                        C
7830 C                                                                              C
7831 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7832 C
7833 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7834 C           energy moment and not to the cluster cumulant.
7835 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7836       iti=itortyp(itype(i))
7837       itj=itortyp(itype(j))
7838       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7839         itj1=itortyp(itype(j+1))
7840       else
7841         itj1=ntortyp+1
7842       endif
7843       itk=itortyp(itype(k))
7844       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7845         itk1=itortyp(itype(k+1))
7846       else
7847         itk1=ntortyp+1
7848       endif
7849       itl=itortyp(itype(l))
7850       if (l.lt.nres-1) then
7851         itl1=itortyp(itype(l+1))
7852       else
7853         itl1=ntortyp+1
7854       endif
7855 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7856 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7857 cd     & ' itl',itl,' itl1',itl1
7858 #ifdef MOMENT
7859       if (imat.eq.1) then
7860         s1=dip(3,jj,i)*dip(3,kk,k)
7861       else
7862         s1=dip(2,jj,j)*dip(2,kk,l)
7863       endif
7864 #endif
7865       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7866       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7867       if (j.eq.l+1) then
7868         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7869         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7870       else
7871         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7872         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7873       endif
7874       call transpose2(EUg(1,1,k),auxmat(1,1))
7875       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7876       vv(1)=pizda(1,1)-pizda(2,2)
7877       vv(2)=pizda(2,1)+pizda(1,2)
7878       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7879 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7880 #ifdef MOMENT
7881       eello6_graph4=-(s1+s2+s3+s4)
7882 #else
7883       eello6_graph4=-(s2+s3+s4)
7884 #endif
7885       if (.not. calc_grad) return
7886 C Derivatives in gamma(i-1)
7887       if (i.gt.1) then
7888 #ifdef MOMENT
7889         if (imat.eq.1) then
7890           s1=dipderg(2,jj,i)*dip(3,kk,k)
7891         else
7892           s1=dipderg(4,jj,j)*dip(2,kk,l)
7893         endif
7894 #endif
7895         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7896         if (j.eq.l+1) then
7897           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7898           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7899         else
7900           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7901           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7902         endif
7903         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7904         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7905 cd          write (2,*) 'turn6 derivatives'
7906 #ifdef MOMENT
7907           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7908 #else
7909           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7910 #endif
7911         else
7912 #ifdef MOMENT
7913           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7914 #else
7915           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7916 #endif
7917         endif
7918       endif
7919 C Derivatives in gamma(k-1)
7920 #ifdef MOMENT
7921       if (imat.eq.1) then
7922         s1=dip(3,jj,i)*dipderg(2,kk,k)
7923       else
7924         s1=dip(2,jj,j)*dipderg(4,kk,l)
7925       endif
7926 #endif
7927       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7928       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7929       if (j.eq.l+1) then
7930         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7931         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7932       else
7933         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7934         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7935       endif
7936       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7937       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7938       vv(1)=pizda(1,1)-pizda(2,2)
7939       vv(2)=pizda(2,1)+pizda(1,2)
7940       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7941       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7942 #ifdef MOMENT
7943         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7944 #else
7945         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7946 #endif
7947       else
7948 #ifdef MOMENT
7949         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7950 #else
7951         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7952 #endif
7953       endif
7954 C Derivatives in gamma(j-1) or gamma(l-1)
7955       if (l.eq.j+1 .and. l.gt.1) then
7956         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7957         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7958         call matmat2(AECAderg(1,1,imat),auxmat(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         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7963       else if (j.gt.1) then
7964         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7965         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7966         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7967         vv(1)=pizda(1,1)-pizda(2,2)
7968         vv(2)=pizda(2,1)+pizda(1,2)
7969         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7970         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7971           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7972         else
7973           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7974         endif
7975       endif
7976 C Cartesian derivatives.
7977       do iii=1,2
7978         do kkk=1,5
7979           do lll=1,3
7980 #ifdef MOMENT
7981             if (iii.eq.1) then
7982               if (imat.eq.1) then
7983                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7984               else
7985                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7986               endif
7987             else
7988               if (imat.eq.1) then
7989                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7990               else
7991                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7992               endif
7993             endif
7994 #endif
7995             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7996      &        auxvec(1))
7997             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7998             if (j.eq.l+1) then
7999               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8000      &          b1(1,itj1),auxvec(1))
8001               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8002             else
8003               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8004      &          b1(1,itl1),auxvec(1))
8005               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8006             endif
8007             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8008      &        pizda(1,1))
8009             vv(1)=pizda(1,1)-pizda(2,2)
8010             vv(2)=pizda(2,1)+pizda(1,2)
8011             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8012             if (swap) then
8013               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8014 #ifdef MOMENT
8015                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8016      &             -(s1+s2+s4)
8017 #else
8018                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8019      &             -(s2+s4)
8020 #endif
8021                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8022               else
8023 #ifdef MOMENT
8024                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8025 #else
8026                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8027 #endif
8028                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8029               endif
8030             else
8031 #ifdef MOMENT
8032               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8033 #else
8034               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8035 #endif
8036               if (l.eq.j+1) then
8037                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8038               else
8039                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8040               endif
8041             endif
8042           enddo
8043         enddo
8044       enddo
8045       return
8046       end
8047 c----------------------------------------------------------------------------
8048       double precision function eello_turn6(i,jj,kk)
8049       implicit real*8 (a-h,o-z)
8050       include 'DIMENSIONS'
8051       include 'DIMENSIONS.ZSCOPT'
8052       include 'COMMON.IOUNITS'
8053       include 'COMMON.CHAIN'
8054       include 'COMMON.DERIV'
8055       include 'COMMON.INTERACT'
8056       include 'COMMON.CONTACTS'
8057       include 'COMMON.TORSION'
8058       include 'COMMON.VAR'
8059       include 'COMMON.GEO'
8060       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8061      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8062      &  ggg1(3),ggg2(3)
8063       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8064      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8065 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8066 C           the respective energy moment and not to the cluster cumulant.
8067       eello_turn6=0.0d0
8068       j=i+4
8069       k=i+1
8070       l=i+3
8071       iti=itortyp(itype(i))
8072       itk=itortyp(itype(k))
8073       itk1=itortyp(itype(k+1))
8074       itl=itortyp(itype(l))
8075       itj=itortyp(itype(j))
8076 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8077 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8078 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8079 cd        eello6=0.0d0
8080 cd        return
8081 cd      endif
8082 cd      write (iout,*)
8083 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8084 cd     &   ' and',k,l
8085 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8086       do iii=1,2
8087         do kkk=1,5
8088           do lll=1,3
8089             derx_turn(lll,kkk,iii)=0.0d0
8090           enddo
8091         enddo
8092       enddo
8093 cd      eij=1.0d0
8094 cd      ekl=1.0d0
8095 cd      ekont=1.0d0
8096       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8097 cd      eello6_5=0.0d0
8098 cd      write (2,*) 'eello6_5',eello6_5
8099 #ifdef MOMENT
8100       call transpose2(AEA(1,1,1),auxmat(1,1))
8101       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8102       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8103       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8104 #else
8105       s1 = 0.0d0
8106 #endif
8107       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8108       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8109       s2 = scalar2(b1(1,itk),vtemp1(1))
8110 #ifdef MOMENT
8111       call transpose2(AEA(1,1,2),atemp(1,1))
8112       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8113       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8114       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8115 #else
8116       s8=0.0d0
8117 #endif
8118       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8119       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8120       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8121 #ifdef MOMENT
8122       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8123       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8124       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8125       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8126       ss13 = scalar2(b1(1,itk),vtemp4(1))
8127       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8128 #else
8129       s13=0.0d0
8130 #endif
8131 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8132 c      s1=0.0d0
8133 c      s2=0.0d0
8134 c      s8=0.0d0
8135 c      s12=0.0d0
8136 c      s13=0.0d0
8137       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8138       if (calc_grad) then
8139 C Derivatives in gamma(i+2)
8140 #ifdef MOMENT
8141       call transpose2(AEA(1,1,1),auxmatd(1,1))
8142       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8143       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8144       call transpose2(AEAderg(1,1,2),atempd(1,1))
8145       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8146       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8147 #else
8148       s8d=0.0d0
8149 #endif
8150       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8151       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8152       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8153 c      s1d=0.0d0
8154 c      s2d=0.0d0
8155 c      s8d=0.0d0
8156 c      s12d=0.0d0
8157 c      s13d=0.0d0
8158       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8159 C Derivatives in gamma(i+3)
8160 #ifdef MOMENT
8161       call transpose2(AEA(1,1,1),auxmatd(1,1))
8162       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8163       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8164       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8165 #else
8166       s1d=0.0d0
8167 #endif
8168       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8169       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8170       s2d = scalar2(b1(1,itk),vtemp1d(1))
8171 #ifdef MOMENT
8172       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8173       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8174 #endif
8175       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8176 #ifdef MOMENT
8177       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8178       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8179       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8180 #else
8181       s13d=0.0d0
8182 #endif
8183 c      s1d=0.0d0
8184 c      s2d=0.0d0
8185 c      s8d=0.0d0
8186 c      s12d=0.0d0
8187 c      s13d=0.0d0
8188 #ifdef MOMENT
8189       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8190      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8191 #else
8192       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8193      &               -0.5d0*ekont*(s2d+s12d)
8194 #endif
8195 C Derivatives in gamma(i+4)
8196       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8197       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8198       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8199 #ifdef MOMENT
8200       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8201       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8202       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8203 #else
8204       s13d = 0.0d0
8205 #endif
8206 c      s1d=0.0d0
8207 c      s2d=0.0d0
8208 c      s8d=0.0d0
8209 C      s12d=0.0d0
8210 c      s13d=0.0d0
8211 #ifdef MOMENT
8212       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8213 #else
8214       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8215 #endif
8216 C Derivatives in gamma(i+5)
8217 #ifdef MOMENT
8218       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8219       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8220       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8221 #else
8222       s1d = 0.0d0
8223 #endif
8224       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8225       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8226       s2d = scalar2(b1(1,itk),vtemp1d(1))
8227 #ifdef MOMENT
8228       call transpose2(AEA(1,1,2),atempd(1,1))
8229       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8230       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8231 #else
8232       s8d = 0.0d0
8233 #endif
8234       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8235       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8236 #ifdef MOMENT
8237       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8238       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8239       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8240 #else
8241       s13d = 0.0d0
8242 #endif
8243 c      s1d=0.0d0
8244 c      s2d=0.0d0
8245 c      s8d=0.0d0
8246 c      s12d=0.0d0
8247 c      s13d=0.0d0
8248 #ifdef MOMENT
8249       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8250      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8251 #else
8252       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8253      &               -0.5d0*ekont*(s2d+s12d)
8254 #endif
8255 C Cartesian derivatives
8256       do iii=1,2
8257         do kkk=1,5
8258           do lll=1,3
8259 #ifdef MOMENT
8260             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8261             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8262             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8263 #else
8264             s1d = 0.0d0
8265 #endif
8266             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8267             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8268      &          vtemp1d(1))
8269             s2d = scalar2(b1(1,itk),vtemp1d(1))
8270 #ifdef MOMENT
8271             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8272             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8273             s8d = -(atempd(1,1)+atempd(2,2))*
8274      &           scalar2(cc(1,1,itl),vtemp2(1))
8275 #else
8276             s8d = 0.0d0
8277 #endif
8278             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8279      &           auxmatd(1,1))
8280             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8281             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8282 c      s1d=0.0d0
8283 c      s2d=0.0d0
8284 c      s8d=0.0d0
8285 c      s12d=0.0d0
8286 c      s13d=0.0d0
8287 #ifdef MOMENT
8288             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8289      &        - 0.5d0*(s1d+s2d)
8290 #else
8291             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8292      &        - 0.5d0*s2d
8293 #endif
8294 #ifdef MOMENT
8295             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8296      &        - 0.5d0*(s8d+s12d)
8297 #else
8298             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8299      &        - 0.5d0*s12d
8300 #endif
8301           enddo
8302         enddo
8303       enddo
8304 #ifdef MOMENT
8305       do kkk=1,5
8306         do lll=1,3
8307           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8308      &      achuj_tempd(1,1))
8309           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8310           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8311           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8312           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8313           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8314      &      vtemp4d(1))
8315           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8316           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8317           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8318         enddo
8319       enddo
8320 #endif
8321 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8322 cd     &  16*eel_turn6_num
8323 cd      goto 1112
8324       if (j.lt.nres-1) then
8325         j1=j+1
8326         j2=j-1
8327       else
8328         j1=j-1
8329         j2=j-2
8330       endif
8331       if (l.lt.nres-1) then
8332         l1=l+1
8333         l2=l-1
8334       else
8335         l1=l-1
8336         l2=l-2
8337       endif
8338       do ll=1,3
8339         ggg1(ll)=eel_turn6*g_contij(ll,1)
8340         ggg2(ll)=eel_turn6*g_contij(ll,2)
8341         ghalf=0.5d0*ggg1(ll)
8342 cd        ghalf=0.0d0
8343         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8344      &    +ekont*derx_turn(ll,2,1)
8345         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8346         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8347      &    +ekont*derx_turn(ll,4,1)
8348         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8349         ghalf=0.5d0*ggg2(ll)
8350 cd        ghalf=0.0d0
8351         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8352      &    +ekont*derx_turn(ll,2,2)
8353         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8354         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8355      &    +ekont*derx_turn(ll,4,2)
8356         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8357       enddo
8358 cd      goto 1112
8359       do m=i+1,j-1
8360         do ll=1,3
8361           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8362         enddo
8363       enddo
8364       do m=k+1,l-1
8365         do ll=1,3
8366           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8367         enddo
8368       enddo
8369 1112  continue
8370       do m=i+2,j2
8371         do ll=1,3
8372           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8373         enddo
8374       enddo
8375       do m=k+2,l2
8376         do ll=1,3
8377           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8378         enddo
8379       enddo
8380 cd      do iii=1,nres-3
8381 cd        write (2,*) iii,g_corr6_loc(iii)
8382 cd      enddo
8383       endif
8384       eello_turn6=ekont*eel_turn6
8385 cd      write (2,*) 'ekont',ekont
8386 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8387       return
8388       end
8389 crc-------------------------------------------------
8390 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8391       subroutine Eliptransfer(eliptran)
8392       implicit real*8 (a-h,o-z)
8393       include 'DIMENSIONS'
8394       include 'COMMON.GEO'
8395       include 'COMMON.VAR'
8396       include 'COMMON.LOCAL'
8397       include 'COMMON.CHAIN'
8398       include 'COMMON.DERIV'
8399       include 'COMMON.INTERACT'
8400       include 'COMMON.IOUNITS'
8401       include 'COMMON.CALC'
8402       include 'COMMON.CONTROL'
8403       include 'COMMON.SPLITELE'
8404       include 'COMMON.SBRIDGE'
8405 C this is done by Adasko
8406 C      print *,"wchodze"
8407 C structure of box:
8408 C      water
8409 C--bordliptop-- buffore starts
8410 C--bufliptop--- here true lipid starts
8411 C      lipid
8412 C--buflipbot--- lipid ends buffore starts
8413 C--bordlipbot--buffore ends
8414       eliptran=0.0
8415       do i=1,nres
8416 C       do i=1,1
8417         if (itype(i).eq.ntyp1) cycle
8418
8419         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8420         if (positi.le.0) positi=positi+boxzsize
8421 C        print *,i
8422 C first for peptide groups
8423 c for each residue check if it is in lipid or lipid water border area
8424        if ((positi.gt.bordlipbot)
8425      &.and.(positi.lt.bordliptop)) then
8426 C the energy transfer exist
8427         if (positi.lt.buflipbot) then
8428 C what fraction I am in
8429          fracinbuf=1.0d0-
8430      &        ((positi-bordlipbot)/lipbufthick)
8431 C lipbufthick is thickenes of lipid buffore
8432          sslip=sscalelip(fracinbuf)
8433          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8434          eliptran=eliptran+sslip*pepliptran
8435          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8436          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8437 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8438         elseif (positi.gt.bufliptop) then
8439          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8440          sslip=sscalelip(fracinbuf)
8441          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8442          eliptran=eliptran+sslip*pepliptran
8443          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8444          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8445 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8446 C          print *, "doing sscalefor top part"
8447 C         print *,i,sslip,fracinbuf,ssgradlip
8448         else
8449          eliptran=eliptran+pepliptran
8450 C         print *,"I am in true lipid"
8451         endif
8452 C       else
8453 C       eliptran=elpitran+0.0 ! I am in water
8454        endif
8455        enddo
8456 C       print *, "nic nie bylo w lipidzie?"
8457 C now multiply all by the peptide group transfer factor
8458 C       eliptran=eliptran*pepliptran
8459 C now the same for side chains
8460 CV       do i=1,1
8461        do i=1,nres
8462         if (itype(i).eq.ntyp1) cycle
8463         positi=(mod(c(3,i+nres),boxzsize))
8464         if (positi.le.0) positi=positi+boxzsize
8465 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8466 c for each residue check if it is in lipid or lipid water border area
8467 C       respos=mod(c(3,i+nres),boxzsize)
8468 C       print *,positi,bordlipbot,buflipbot
8469        if ((positi.gt.bordlipbot)
8470      & .and.(positi.lt.bordliptop)) then
8471 C the energy transfer exist
8472         if (positi.lt.buflipbot) then
8473          fracinbuf=1.0d0-
8474      &     ((positi-bordlipbot)/lipbufthick)
8475 C lipbufthick is thickenes of lipid buffore
8476          sslip=sscalelip(fracinbuf)
8477          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8478          eliptran=eliptran+sslip*liptranene(itype(i))
8479          gliptranx(3,i)=gliptranx(3,i)
8480      &+ssgradlip*liptranene(itype(i))
8481          gliptranc(3,i-1)= gliptranc(3,i-1)
8482      &+ssgradlip*liptranene(itype(i))
8483 C         print *,"doing sccale for lower part"
8484         elseif (positi.gt.bufliptop) then
8485          fracinbuf=1.0d0-
8486      &((bordliptop-positi)/lipbufthick)
8487          sslip=sscalelip(fracinbuf)
8488          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8489          eliptran=eliptran+sslip*liptranene(itype(i))
8490          gliptranx(3,i)=gliptranx(3,i)
8491      &+ssgradlip*liptranene(itype(i))
8492          gliptranc(3,i-1)= gliptranc(3,i-1)
8493      &+ssgradlip*liptranene(itype(i))
8494 C          print *, "doing sscalefor top part",sslip,fracinbuf
8495         else
8496          eliptran=eliptran+liptranene(itype(i))
8497 C         print *,"I am in true lipid"
8498         endif
8499         endif ! if in lipid or buffor
8500 C       else
8501 C       eliptran=elpitran+0.0 ! I am in water
8502        enddo
8503        return
8504        end
8505
8506
8507 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8508
8509       SUBROUTINE MATVEC2(A1,V1,V2)
8510       implicit real*8 (a-h,o-z)
8511       include 'DIMENSIONS'
8512       DIMENSION A1(2,2),V1(2),V2(2)
8513 c      DO 1 I=1,2
8514 c        VI=0.0
8515 c        DO 3 K=1,2
8516 c    3     VI=VI+A1(I,K)*V1(K)
8517 c        Vaux(I)=VI
8518 c    1 CONTINUE
8519
8520       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8521       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8522
8523       v2(1)=vaux1
8524       v2(2)=vaux2
8525       END
8526 C---------------------------------------
8527       SUBROUTINE MATMAT2(A1,A2,A3)
8528       implicit real*8 (a-h,o-z)
8529       include 'DIMENSIONS'
8530       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8531 c      DIMENSION AI3(2,2)
8532 c        DO  J=1,2
8533 c          A3IJ=0.0
8534 c          DO K=1,2
8535 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8536 c          enddo
8537 c          A3(I,J)=A3IJ
8538 c       enddo
8539 c      enddo
8540
8541       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8542       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8543       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8544       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8545
8546       A3(1,1)=AI3_11
8547       A3(2,1)=AI3_21
8548       A3(1,2)=AI3_12
8549       A3(2,2)=AI3_22
8550       END
8551
8552 c-------------------------------------------------------------------------
8553       double precision function scalar2(u,v)
8554       implicit none
8555       double precision u(2),v(2)
8556       double precision sc
8557       integer i
8558       scalar2=u(1)*v(1)+u(2)*v(2)
8559       return
8560       end
8561
8562 C-----------------------------------------------------------------------------
8563
8564       subroutine transpose2(a,at)
8565       implicit none
8566       double precision a(2,2),at(2,2)
8567       at(1,1)=a(1,1)
8568       at(1,2)=a(2,1)
8569       at(2,1)=a(1,2)
8570       at(2,2)=a(2,2)
8571       return
8572       end
8573 c--------------------------------------------------------------------------
8574       subroutine transpose(n,a,at)
8575       implicit none
8576       integer n,i,j
8577       double precision a(n,n),at(n,n)
8578       do i=1,n
8579         do j=1,n
8580           at(j,i)=a(i,j)
8581         enddo
8582       enddo
8583       return
8584       end
8585 C---------------------------------------------------------------------------
8586       subroutine prodmat3(a1,a2,kk,transp,prod)
8587       implicit none
8588       integer i,j
8589       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8590       logical transp
8591 crc      double precision auxmat(2,2),prod_(2,2)
8592
8593       if (transp) then
8594 crc        call transpose2(kk(1,1),auxmat(1,1))
8595 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8596 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8597
8598            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8599      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8600            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8601      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8602            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8603      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8604            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8605      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8606
8607       else
8608 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8609 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8610
8611            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8612      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8613            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8614      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8615            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8616      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8617            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8618      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8619
8620       endif
8621 c      call transpose2(a2(1,1),a2t(1,1))
8622
8623 crc      print *,transp
8624 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8625 crc      print *,((prod(i,j),i=1,2),j=1,2)
8626
8627       return
8628       end
8629 C-----------------------------------------------------------------------------
8630       double precision function scalar(u,v)
8631       implicit none
8632       double precision u(3),v(3)
8633       double precision sc
8634       integer i
8635       sc=0.0d0
8636       do i=1,3
8637         sc=sc+u(i)*v(i)
8638       enddo
8639       scalar=sc
8640       return
8641       end
8642 C-----------------------------------------------------------------------
8643       double precision function sscale(r)
8644       double precision r,gamm
8645       include "COMMON.SPLITELE"
8646       if(r.lt.r_cut-rlamb) then
8647         sscale=1.0d0
8648       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8649         gamm=(r-(r_cut-rlamb))/rlamb
8650         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8651       else
8652         sscale=0d0
8653       endif
8654       return
8655       end
8656 C-----------------------------------------------------------------------
8657 C-----------------------------------------------------------------------
8658       double precision function sscagrad(r)
8659       double precision r,gamm
8660       include "COMMON.SPLITELE"
8661       if(r.lt.r_cut-rlamb) then
8662         sscagrad=0.0d0
8663       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8664         gamm=(r-(r_cut-rlamb))/rlamb
8665         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8666       else
8667         sscagrad=0.0d0
8668       endif
8669       return
8670       end
8671 C-----------------------------------------------------------------------
8672 C-----------------------------------------------------------------------
8673       double precision function sscalelip(r)
8674       double precision r,gamm
8675       include "COMMON.SPLITELE"
8676 C      if(r.lt.r_cut-rlamb) then
8677 C        sscale=1.0d0
8678 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8679 C        gamm=(r-(r_cut-rlamb))/rlamb
8680         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8681 C      else
8682 C        sscale=0d0
8683 C      endif
8684       return
8685       end
8686 C-----------------------------------------------------------------------
8687       double precision function sscagradlip(r)
8688       double precision r,gamm
8689       include "COMMON.SPLITELE"
8690 C     if(r.lt.r_cut-rlamb) then
8691 C        sscagrad=0.0d0
8692 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8693 C        gamm=(r-(r_cut-rlamb))/rlamb
8694         sscagradlip=r*(6*r-6.0d0)
8695 C      else
8696 C        sscagrad=0.0d0
8697 C      endif
8698       return
8699       end
8700
8701 C-----------------------------------------------------------------------
8702        subroutine set_shield_fac
8703       implicit real*8 (a-h,o-z)
8704       include 'DIMENSIONS'
8705       include 'COMMON.CHAIN'
8706       include 'COMMON.DERIV'
8707       include 'COMMON.IOUNITS'
8708       include 'COMMON.SHIELD'
8709       include 'COMMON.INTERACT'
8710 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8711       double precision div77_81/0.974996043d0/,
8712      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8713
8714 C the vector between center of side_chain and peptide group
8715        double precision pep_side(3),long,side_calf(3),
8716      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8717      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8718 C the line belowe needs to be changed for FGPROC>1
8719       do i=1,nres-1
8720       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8721       ishield_list(i)=0
8722 Cif there two consequtive dummy atoms there is no peptide group between them
8723 C the line below has to be changed for FGPROC>1
8724       VolumeTotal=0.0
8725       do k=1,nres
8726        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8727        dist_pep_side=0.0
8728        dist_side_calf=0.0
8729        do j=1,3
8730 C first lets set vector conecting the ithe side-chain with kth side-chain
8731       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8732 C      pep_side(j)=2.0d0
8733 C and vector conecting the side-chain with its proper calfa
8734       side_calf(j)=c(j,k+nres)-c(j,k)
8735 C      side_calf(j)=2.0d0
8736       pept_group(j)=c(j,i)-c(j,i+1)
8737 C lets have their lenght
8738       dist_pep_side=pep_side(j)**2+dist_pep_side
8739       dist_side_calf=dist_side_calf+side_calf(j)**2
8740       dist_pept_group=dist_pept_group+pept_group(j)**2
8741       enddo
8742        dist_pep_side=dsqrt(dist_pep_side)
8743        dist_pept_group=dsqrt(dist_pept_group)
8744        dist_side_calf=dsqrt(dist_side_calf)
8745       do j=1,3
8746         pep_side_norm(j)=pep_side(j)/dist_pep_side
8747         side_calf_norm(j)=dist_side_calf
8748       enddo
8749 C now sscale fraction
8750        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8751 C       print *,buff_shield,"buff"
8752 C now sscale
8753         if (sh_frac_dist.le.0.0) cycle
8754 C If we reach here it means that this side chain reaches the shielding sphere
8755 C Lets add him to the list for gradient
8756         ishield_list(i)=ishield_list(i)+1
8757 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8758 C this list is essential otherwise problem would be O3
8759         shield_list(ishield_list(i),i)=k
8760 C Lets have the sscale value
8761         if (sh_frac_dist.gt.1.0) then
8762          scale_fac_dist=1.0d0
8763          do j=1,3
8764          sh_frac_dist_grad(j)=0.0d0
8765          enddo
8766         else
8767          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8768      &                   *(2.0*sh_frac_dist-3.0d0)
8769          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8770      &                  /dist_pep_side/buff_shield*0.5
8771 C remember for the final gradient multiply sh_frac_dist_grad(j)
8772 C for side_chain by factor -2 !
8773          do j=1,3
8774          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8775 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8776 C     &                    sh_frac_dist_grad(j)
8777          enddo
8778         endif
8779 C        if ((i.eq.3).and.(k.eq.2)) then
8780 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8781 C     & ,"TU"
8782 C        endif
8783
8784 C this is what is now we have the distance scaling now volume...
8785       short=short_r_sidechain(itype(k))
8786       long=long_r_sidechain(itype(k))
8787       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8788 C now costhet_grad
8789 C       costhet=0.0d0
8790        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8791 C       costhet_fac=0.0d0
8792        do j=1,3
8793          costhet_grad(j)=costhet_fac*pep_side(j)
8794        enddo
8795 C remember for the final gradient multiply costhet_grad(j)
8796 C for side_chain by factor -2 !
8797 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8798 C pep_side0pept_group is vector multiplication
8799       pep_side0pept_group=0.0
8800       do j=1,3
8801       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8802       enddo
8803       cosalfa=(pep_side0pept_group/
8804      & (dist_pep_side*dist_side_calf))
8805       fac_alfa_sin=1.0-cosalfa**2
8806       fac_alfa_sin=dsqrt(fac_alfa_sin)
8807       rkprim=fac_alfa_sin*(long-short)+short
8808 C now costhet_grad
8809        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8810        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8811
8812        do j=1,3
8813          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8814      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8815      &*(long-short)/fac_alfa_sin*cosalfa/
8816      &((dist_pep_side*dist_side_calf))*
8817      &((side_calf(j))-cosalfa*
8818      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8819
8820         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8821      &*(long-short)/fac_alfa_sin*cosalfa
8822      &/((dist_pep_side*dist_side_calf))*
8823      &(pep_side(j)-
8824      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8825        enddo
8826
8827       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8828      &                    /VSolvSphere_div
8829      &                    *wshield
8830 C now the gradient...
8831 C grad_shield is gradient of Calfa for peptide groups
8832 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8833 C     &               costhet,cosphi
8834 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8835 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8836       do j=1,3
8837       grad_shield(j,i)=grad_shield(j,i)
8838 C gradient po skalowaniu
8839      &                +(sh_frac_dist_grad(j)
8840 C  gradient po costhet
8841      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8842      &-scale_fac_dist*(cosphi_grad_long(j))
8843      &/(1.0-cosphi) )*div77_81
8844      &*VofOverlap
8845 C grad_shield_side is Cbeta sidechain gradient
8846       grad_shield_side(j,ishield_list(i),i)=
8847      &        (sh_frac_dist_grad(j)*-2.0d0
8848      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8849      &       +scale_fac_dist*(cosphi_grad_long(j))
8850      &        *2.0d0/(1.0-cosphi))
8851      &        *div77_81*VofOverlap
8852
8853        grad_shield_loc(j,ishield_list(i),i)=
8854      &   scale_fac_dist*cosphi_grad_loc(j)
8855      &        *2.0d0/(1.0-cosphi)
8856      &        *div77_81*VofOverlap
8857       enddo
8858       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8859       enddo
8860       fac_shield(i)=VolumeTotal*div77_81+div4_81
8861 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8862       enddo
8863       return
8864       end
8865 C--------------------------------------------------------------------------
8866 C first for shielding is setting of function of side-chains
8867        subroutine set_shield_fac2
8868       implicit real*8 (a-h,o-z)
8869       include 'DIMENSIONS'
8870       include 'COMMON.CHAIN'
8871       include 'COMMON.DERIV'
8872       include 'COMMON.IOUNITS'
8873       include 'COMMON.SHIELD'
8874       include 'COMMON.INTERACT'
8875 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8876       double precision div77_81/0.974996043d0/,
8877      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8878
8879 C the vector between center of side_chain and peptide group
8880        double precision pep_side(3),long,side_calf(3),
8881      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8882      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8883 C the line belowe needs to be changed for FGPROC>1
8884       do i=1,nres-1
8885       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8886       ishield_list(i)=0
8887 Cif there two consequtive dummy atoms there is no peptide group between them
8888 C the line below has to be changed for FGPROC>1
8889       VolumeTotal=0.0
8890       do k=1,nres
8891        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8892        dist_pep_side=0.0
8893        dist_side_calf=0.0
8894        do j=1,3
8895 C first lets set vector conecting the ithe side-chain with kth side-chain
8896       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8897 C      pep_side(j)=2.0d0
8898 C and vector conecting the side-chain with its proper calfa
8899       side_calf(j)=c(j,k+nres)-c(j,k)
8900 C      side_calf(j)=2.0d0
8901       pept_group(j)=c(j,i)-c(j,i+1)
8902 C lets have their lenght
8903       dist_pep_side=pep_side(j)**2+dist_pep_side
8904       dist_side_calf=dist_side_calf+side_calf(j)**2
8905       dist_pept_group=dist_pept_group+pept_group(j)**2
8906       enddo
8907        dist_pep_side=dsqrt(dist_pep_side)
8908        dist_pept_group=dsqrt(dist_pept_group)
8909        dist_side_calf=dsqrt(dist_side_calf)
8910       do j=1,3
8911         pep_side_norm(j)=pep_side(j)/dist_pep_side
8912         side_calf_norm(j)=dist_side_calf
8913       enddo
8914 C now sscale fraction
8915        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8916 C       print *,buff_shield,"buff"
8917 C now sscale
8918         if (sh_frac_dist.le.0.0) cycle
8919 C If we reach here it means that this side chain reaches the shielding sphere
8920 C Lets add him to the list for gradient
8921         ishield_list(i)=ishield_list(i)+1
8922 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8923 C this list is essential otherwise problem would be O3
8924         shield_list(ishield_list(i),i)=k
8925 C Lets have the sscale value
8926         if (sh_frac_dist.gt.1.0) then
8927          scale_fac_dist=1.0d0
8928          do j=1,3
8929          sh_frac_dist_grad(j)=0.0d0
8930          enddo
8931         else
8932          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8933      &                   *(2.0d0*sh_frac_dist-3.0d0)
8934          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8935      &                  /dist_pep_side/buff_shield*0.5d0
8936 C remember for the final gradient multiply sh_frac_dist_grad(j)
8937 C for side_chain by factor -2 !
8938          do j=1,3
8939          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8940 C         sh_frac_dist_grad(j)=0.0d0
8941 C         scale_fac_dist=1.0d0
8942 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8943 C     &                    sh_frac_dist_grad(j)
8944          enddo
8945         endif
8946 C this is what is now we have the distance scaling now volume...
8947       short=short_r_sidechain(itype(k))
8948       long=long_r_sidechain(itype(k))
8949       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8950       sinthet=short/dist_pep_side*costhet
8951 C now costhet_grad
8952 C       costhet=0.6d0
8953 C       sinthet=0.8
8954        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8955 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8956 C     &             -short/dist_pep_side**2/costhet)
8957 C       costhet_fac=0.0d0
8958        do j=1,3
8959          costhet_grad(j)=costhet_fac*pep_side(j)
8960        enddo
8961 C remember for the final gradient multiply costhet_grad(j)
8962 C for side_chain by factor -2 !
8963 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8964 C pep_side0pept_group is vector multiplication
8965       pep_side0pept_group=0.0d0
8966       do j=1,3
8967       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8968       enddo
8969       cosalfa=(pep_side0pept_group/
8970      & (dist_pep_side*dist_side_calf))
8971       fac_alfa_sin=1.0d0-cosalfa**2
8972       fac_alfa_sin=dsqrt(fac_alfa_sin)
8973       rkprim=fac_alfa_sin*(long-short)+short
8974 C      rkprim=short
8975
8976 C now costhet_grad
8977        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8978 C       cosphi=0.6
8979        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8980        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8981      &      dist_pep_side**2)
8982 C       sinphi=0.8
8983        do j=1,3
8984          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8985      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8986      &*(long-short)/fac_alfa_sin*cosalfa/
8987      &((dist_pep_side*dist_side_calf))*
8988      &((side_calf(j))-cosalfa*
8989      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8990 C       cosphi_grad_long(j)=0.0d0
8991         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8992      &*(long-short)/fac_alfa_sin*cosalfa
8993      &/((dist_pep_side*dist_side_calf))*
8994      &(pep_side(j)-
8995      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8996 C       cosphi_grad_loc(j)=0.0d0
8997        enddo
8998 C      print *,sinphi,sinthet
8999       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9000      &                    /VSolvSphere_div
9001 C     &                    *wshield
9002 C now the gradient...
9003       do j=1,3
9004       grad_shield(j,i)=grad_shield(j,i)
9005 C gradient po skalowaniu
9006      &                +(sh_frac_dist_grad(j)*VofOverlap
9007 C  gradient po costhet
9008      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9009      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9010      &       sinphi/sinthet*costhet*costhet_grad(j)
9011      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9012      & )*wshield
9013 C grad_shield_side is Cbeta sidechain gradient
9014       grad_shield_side(j,ishield_list(i),i)=
9015      &        (sh_frac_dist_grad(j)*-2.0d0
9016      &        *VofOverlap
9017      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9018      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9019      &       sinphi/sinthet*costhet*costhet_grad(j)
9020      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9021      &       )*wshield
9022
9023        grad_shield_loc(j,ishield_list(i),i)=
9024      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9025      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9026      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9027      &        ))
9028      &        *wshield
9029       enddo
9030       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9031       enddo
9032       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9033 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9034 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9035       enddo
9036       return
9037       end
9038