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       if (calc_grad) then
 228 C
 229 C Sum up the components of the Cartesian gradient.
 230 C
 231 #ifdef SPLITELE
 232       do i=1,nct
 233         do j=1,3
 234       if (shield_mode.eq.0) then
 235           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 236      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 237      &                wbond*gradb(j,i)+
 238      &                wstrain*ghpbc(j,i)+
 239      &                wcorr*fact(3)*gradcorr(j,i)+
 240      &                wel_loc*fact(2)*gel_loc(j,i)+
 241      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 242      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 243      &                wcorr5*fact(4)*gradcorr5(j,i)+
 244      &                wcorr6*fact(5)*gradcorr6(j,i)+
 245      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 246      &                wsccor*fact(2)*gsccorc(j,i)
 247      &               +wliptran*gliptranc(j,i)
 248           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 249      &                  wbond*gradbx(j,i)+
 250      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 251      &                  wsccor*fact(2)*gsccorx(j,i)
 252      &                 +wliptran*gliptranx(j,i)
 253         else
 254           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 255      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 256      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 257      &                wbond*gradb(j,i)+
 258      &                wstrain*ghpbc(j,i)+
 259      &                wcorr*fact(3)*gradcorr(j,i)+
 260      &                wel_loc*fact(2)*gel_loc(j,i)+
 261      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 262      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 263      &                wcorr5*fact(4)*gradcorr5(j,i)+
 264      &                wcorr6*fact(5)*gradcorr6(j,i)+
 265      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 266      &                wsccor*fact(2)*gsccorc(j,i)
 267      &               +wliptran*gliptranc(j,i)
 268           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 269      &                 +fact(1)*wscp*gradx_scp(j,i)+
 270      &                  wbond*gradbx(j,i)+
 271      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 272      &                  wsccor*fact(2)*gsccorx(j,i)
 273      &                 +wliptran*gliptranx(j,i)
 274
 275         endif
 276         enddo
 277 #else
 278       do i=1,nct
 279         do j=1,3
 280                 if (shield_mode.eq.0) then
 281           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 282      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 283      &                wbond*gradb(j,i)+
 284      &                wcorr*fact(3)*gradcorr(j,i)+
 285      &                wel_loc*fact(2)*gel_loc(j,i)+
 286      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 287      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 288      &                wcorr5*fact(4)*gradcorr5(j,i)+
 289      &                wcorr6*fact(5)*gradcorr6(j,i)+
 290      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 291      &                wsccor*fact(2)*gsccorc(j,i)
 292      &               +wliptran*gliptranc(j,i)
 293           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 294      &                  wbond*gradbx(j,i)+
 295      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 296      &                  wsccor*fact(1)*gsccorx(j,i)
 297      &                 +wliptran*gliptranx(j,i)
 298               else
 299           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 300      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 301      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 302      &                wbond*gradb(j,i)+
 303      &                wcorr*fact(3)*gradcorr(j,i)+
 304      &                wel_loc*fact(2)*gel_loc(j,i)+
 305      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 306      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 307      &                wcorr5*fact(4)*gradcorr5(j,i)+
 308      &                wcorr6*fact(5)*gradcorr6(j,i)+
 309      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 310      &                wsccor*fact(2)*gsccorc(j,i)
 311      &               +wliptran*gliptranc(j,i)
 312           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 313      &                  fact(1)*wscp*gradx_scp(j,i)+
 314      &                  wbond*gradbx(j,i)+
 315      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 316      &                  wsccor*fact(1)*gsccorx(j,i)
 317      &                 +wliptran*gliptranx(j,i)
 318          endif
 319         enddo
 320 #endif
 321       enddo
 322
 323
 324       do i=1,nres-3
 325         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 326      &   +wcorr5*fact(4)*g_corr5_loc(i)
 327      &   +wcorr6*fact(5)*g_corr6_loc(i)
 328      &   +wturn4*fact(3)*gel_loc_turn4(i)
 329      &   +wturn3*fact(2)*gel_loc_turn3(i)
 330      &   +wturn6*fact(5)*gel_loc_turn6(i)
 331      &   +wel_loc*fact(2)*gel_loc_loc(i)
 332 c     &   +wsccor*fact(1)*gsccor_loc(i)
 333 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 334       enddo
 335       endif
 336       if (dyn_ss) call dyn_set_nss
 337       return
 338       end
 339 C------------------------------------------------------------------------
 340       subroutine enerprint(energia,fact)
 341       implicit real*8 (a-h,o-z)
 342       include 'DIMENSIONS'
 343       include 'DIMENSIONS.ZSCOPT'
 344       include 'COMMON.IOUNITS'
 345       include 'COMMON.FFIELD'
 346       include 'COMMON.SBRIDGE'
 347       double precision energia(0:max_ene),fact(6)
 348       etot=energia(0)
 349       evdw=energia(1)+fact(6)*energia(21)
 350 #ifdef SCP14
 351       evdw2=energia(2)+energia(17)
 352 #else
 353       evdw2=energia(2)
 354 #endif
 355       ees=energia(3)
 356 #ifdef SPLITELE
 357       evdw1=energia(16)
 358 #endif
 359       ecorr=energia(4)
 360       ecorr5=energia(5)
 361       ecorr6=energia(6)
 362       eel_loc=energia(7)
 363       eello_turn3=energia(8)
 364       eello_turn4=energia(9)
 365       eello_turn6=energia(10)
 366       ebe=energia(11)
 367       escloc=energia(12)
 368       etors=energia(13)
 369       etors_d=energia(14)
 370       ehpb=energia(15)
 371       esccor=energia(19)
 372       edihcnstr=energia(20)
 373       estr=energia(18)
 374       ethetacnstr=energia(24)
 375       eliptran=energia(22)
 376 #ifdef SPLITELE
 377       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 378      &  wvdwpp,
 379      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 380      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 381      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 382      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 383      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 384      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 385      & eliptran,wliptran,etot
 386    10 format (/'Virtual-chain energies:'//
 387      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 388      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 389      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 390      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 391      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 392      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 393      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 394      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 395      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 396      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 397      & ' (SS bridges & dist. cnstr.)'/
 398      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 399      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 400      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 401      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 402      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 403      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 404      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 405      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 406      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 407      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 408      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 409      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 410      & 'ETOT=  ',1pE16.6,' (total)')
 411 #else
 412       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 413      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 414      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 415      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 416      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 417      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 418      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 419    10 format (/'Virtual-chain energies:'//
 420      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 421      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 422      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 423      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 424      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 425      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 426      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 427      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 428      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 429      & ' (SS bridges & dist. cnstr.)'/
 430      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 431      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 432      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 433      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 434      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 435      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 436      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 437      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 438      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 439      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 440      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 441      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 442      & 'ETOT=  ',1pE16.6,' (total)')
 443 #endif
 444       return
 445       end
 446 C-----------------------------------------------------------------------
 447       subroutine elj(evdw,evdw_t)
 448 C
 449 C This subroutine calculates the interaction energy of nonbonded side chains
 450 C assuming the LJ potential of interaction.
 451 C
 452       implicit real*8 (a-h,o-z)
 453       include 'DIMENSIONS'
 454       include 'DIMENSIONS.ZSCOPT'
 455       include "DIMENSIONS.COMPAR"
 456       parameter (accur=1.0d-10)
 457       include 'COMMON.GEO'
 458       include 'COMMON.VAR'
 459       include 'COMMON.LOCAL'
 460       include 'COMMON.CHAIN'
 461       include 'COMMON.DERIV'
 462       include 'COMMON.INTERACT'
 463       include 'COMMON.TORSION'
 464       include 'COMMON.ENEPS'
 465       include 'COMMON.SBRIDGE'
 466       include 'COMMON.NAMES'
 467       include 'COMMON.IOUNITS'
 468       include 'COMMON.CONTACTS'
 469       dimension gg(3)
 470       integer icant
 471       external icant
 472 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 473 c ROZNICA z cluster
 474       do i=1,210
 475         do j=1,2
 476           eneps_temp(j,i)=0.0d0
 477         enddo
 478       enddo
 479 cROZNICA
 480
 481       evdw=0.0D0
 482       evdw_t=0.0d0
 483       do i=iatsc_s,iatsc_e
 484         itypi=iabs(itype(i))
 485         if (itypi.eq.ntyp1) cycle
 486         itypi1=iabs(itype(i+1))
 487         xi=c(1,nres+i)
 488         yi=c(2,nres+i)
 489         zi=c(3,nres+i)
 490 C Change 12/1/95
 491         num_conti=0
 492 C
 493 C Calculate SC interaction energy.
 494 C
 495         do iint=1,nint_gr(i)
 496 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 497 cd   &                  'iend=',iend(i,iint)
 498           do j=istart(i,iint),iend(i,iint)
 499             itypj=iabs(itype(j))
 500             if (itypj.eq.ntyp1) cycle
 501             xj=c(1,nres+j)-xi
 502             yj=c(2,nres+j)-yi
 503             zj=c(3,nres+j)-zi
 504 C Change 12/1/95 to calculate four-body interactions
 505             rij=xj*xj+yj*yj+zj*zj
 506             rrij=1.0D0/rij
 507 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 508             eps0ij=eps(itypi,itypj)
 509             fac=rrij**expon2
 510             e1=fac*fac*aa
 511             e2=fac*bb
 512             evdwij=e1+e2
 513             ij=icant(itypi,itypj)
 514 c ROZNICA z cluster
 515             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 516             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 517 c
 518
 519 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 520 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 521 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 522 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 523 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 524 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 525             if (bb.gt.0.0d0) then
 526               evdw=evdw+evdwij
 527             else
 528               evdw_t=evdw_t+evdwij
 529             endif
 530             if (calc_grad) then
 531 C
 532 C Calculate the components of the gradient in DC and X
 533 C
 534             fac=-rrij*(e1+evdwij)
 535             gg(1)=xj*fac
 536             gg(2)=yj*fac
 537             gg(3)=zj*fac
 538             do k=1,3
 539               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 540               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 541             enddo
 542             do k=i,j-1
 543               do l=1,3
 544                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 545               enddo
 546             enddo
 547             endif
 548 C
 549 C 12/1/95, revised on 5/20/97
 550 C
 551 C Calculate the contact function. The ith column of the array JCONT will
 552 C contain the numbers of atoms that make contacts with the atom I (of numbers
 553 C greater than I). The arrays FACONT and GACONT will contain the values of
 554 C the contact function and its derivative.
 555 C
 556 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 557 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 558 C Uncomment next line, if the correlation interactions are contact function only
 559             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 560               rij=dsqrt(rij)
 561               sigij=sigma(itypi,itypj)
 562               r0ij=rs0(itypi,itypj)
 563 C
 564 C Check whether the SC's are not too far to make a contact.
 565 C
 566               rcut=1.5d0*r0ij
 567               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 568 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 569 C
 570               if (fcont.gt.0.0D0) then
 571 C If the SC-SC distance if close to sigma, apply spline.
 572 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 573 cAdam &             fcont1,fprimcont1)
 574 cAdam           fcont1=1.0d0-fcont1
 575 cAdam           if (fcont1.gt.0.0d0) then
 576 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 577 cAdam             fcont=fcont*fcont1
 578 cAdam           endif
 579 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 580 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 581 cga             do k=1,3
 582 cga               gg(k)=gg(k)*eps0ij
 583 cga             enddo
 584 cga             eps0ij=-evdwij*eps0ij
 585 C Uncomment for AL's type of SC correlation interactions.
 586 cadam           eps0ij=-evdwij
 587                 num_conti=num_conti+1
 588                 jcont(num_conti,i)=j
 589                 facont(num_conti,i)=fcont*eps0ij
 590                 fprimcont=eps0ij*fprimcont/rij
 591                 fcont=expon*fcont
 592 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 593 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 594 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 595 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 596                 gacont(1,num_conti,i)=-fprimcont*xj
 597                 gacont(2,num_conti,i)=-fprimcont*yj
 598                 gacont(3,num_conti,i)=-fprimcont*zj
 599 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 600 cd              write (iout,'(2i3,3f10.5)')
 601 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 602               endif
 603             endif
 604           enddo      ! j
 605         enddo        ! iint
 606 C Change 12/1/95
 607         num_cont(i)=num_conti
 608       enddo          ! i
 609       if (calc_grad) then
 610       do i=1,nct
 611         do j=1,3
 612           gvdwc(j,i)=expon*gvdwc(j,i)
 613           gvdwx(j,i)=expon*gvdwx(j,i)
 614         enddo
 615       enddo
 616       endif
 617 C******************************************************************************
 618 C
 619 C                              N O T E !!!
 620 C
 621 C To save time, the factor of EXPON has been extracted from ALL components
 622 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 623 C use!
 624 C
 625 C******************************************************************************
 626       return
 627       end
 628 C-----------------------------------------------------------------------------
 629       subroutine eljk(evdw,evdw_t)
 630 C
 631 C This subroutine calculates the interaction energy of nonbonded side chains
 632 C assuming the LJK potential of interaction.
 633 C
 634       implicit real*8 (a-h,o-z)
 635       include 'DIMENSIONS'
 636       include 'DIMENSIONS.ZSCOPT'
 637       include "DIMENSIONS.COMPAR"
 638       include 'COMMON.GEO'
 639       include 'COMMON.VAR'
 640       include 'COMMON.LOCAL'
 641       include 'COMMON.CHAIN'
 642       include 'COMMON.DERIV'
 643       include 'COMMON.INTERACT'
 644       include 'COMMON.ENEPS'
 645       include 'COMMON.IOUNITS'
 646       include 'COMMON.NAMES'
 647       dimension gg(3)
 648       logical scheck
 649       integer icant
 650       external icant
 651 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 652       do i=1,210
 653         do j=1,2
 654           eneps_temp(j,i)=0.0d0
 655         enddo
 656       enddo
 657       evdw=0.0D0
 658       evdw_t=0.0d0
 659       do i=iatsc_s,iatsc_e
 660         itypi=iabs(itype(i))
 661         if (itypi.eq.ntyp1) cycle
 662         itypi1=iabs(itype(i+1))
 663         xi=c(1,nres+i)
 664         yi=c(2,nres+i)
 665         zi=c(3,nres+i)
 666 C
 667 C Calculate SC interaction energy.
 668 C
 669         do iint=1,nint_gr(i)
 670           do j=istart(i,iint),iend(i,iint)
 671             itypj=iabs(itype(j))
 672             if (itypj.eq.ntyp1) cycle
 673             xj=c(1,nres+j)-xi
 674             yj=c(2,nres+j)-yi
 675             zj=c(3,nres+j)-zi
 676             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 677             fac_augm=rrij**expon
 678             e_augm=augm(itypi,itypj)*fac_augm
 679             r_inv_ij=dsqrt(rrij)
 680             rij=1.0D0/r_inv_ij
 681             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 682             fac=r_shift_inv**expon
 683             e1=fac*fac*aa
 684             e2=fac*bb
 685             evdwij=e_augm+e1+e2
 686             ij=icant(itypi,itypj)
 687             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 688      &        /dabs(eps(itypi,itypj))
 689             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 690 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 691 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 692 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 693 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 694 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 695 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 696 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 697             if (bb.gt.0.0d0) then
 698               evdw=evdw+evdwij
 699             else
 700               evdw_t=evdw_t+evdwij
 701             endif
 702             if (calc_grad) then
 703 C
 704 C Calculate the components of the gradient in DC and X
 705 C
 706             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 707             gg(1)=xj*fac
 708             gg(2)=yj*fac
 709             gg(3)=zj*fac
 710             do k=1,3
 711               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 712               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 713             enddo
 714             do k=i,j-1
 715               do l=1,3
 716                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 717               enddo
 718             enddo
 719             endif
 720           enddo      ! j
 721         enddo        ! iint
 722       enddo          ! i
 723       if (calc_grad) then
 724       do i=1,nct
 725         do j=1,3
 726           gvdwc(j,i)=expon*gvdwc(j,i)
 727           gvdwx(j,i)=expon*gvdwx(j,i)
 728         enddo
 729       enddo
 730       endif
 731       return
 732       end
 733 C-----------------------------------------------------------------------------
 734       subroutine ebp(evdw,evdw_t)
 735 C
 736 C This subroutine calculates the interaction energy of nonbonded side chains
 737 C assuming the Berne-Pechukas potential of interaction.
 738 C
 739       implicit real*8 (a-h,o-z)
 740       include 'DIMENSIONS'
 741       include 'DIMENSIONS.ZSCOPT'
 742       include "DIMENSIONS.COMPAR"
 743       include 'COMMON.GEO'
 744       include 'COMMON.VAR'
 745       include 'COMMON.LOCAL'
 746       include 'COMMON.CHAIN'
 747       include 'COMMON.DERIV'
 748       include 'COMMON.NAMES'
 749       include 'COMMON.INTERACT'
 750       include 'COMMON.ENEPS'
 751       include 'COMMON.IOUNITS'
 752       include 'COMMON.CALC'
 753       common /srutu/ icall
 754 c     double precision rrsave(maxdim)
 755       logical lprn
 756       integer icant
 757       external icant
 758       do i=1,210
 759         do j=1,2
 760           eneps_temp(j,i)=0.0d0
 761         enddo
 762       enddo
 763       evdw=0.0D0
 764       evdw_t=0.0d0
 765 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 766 c     if (icall.eq.0) then
 767 c       lprn=.true.
 768 c     else
 769         lprn=.false.
 770 c     endif
 771       ind=0
 772       do i=iatsc_s,iatsc_e
 773         itypi=iabs(itype(i))
 774         if (itypi.eq.ntyp1) cycle
 775         itypi1=iabs(itype(i+1))
 776         xi=c(1,nres+i)
 777         yi=c(2,nres+i)
 778         zi=c(3,nres+i)
 779         dxi=dc_norm(1,nres+i)
 780         dyi=dc_norm(2,nres+i)
 781         dzi=dc_norm(3,nres+i)
 782         dsci_inv=vbld_inv(i+nres)
 783 C
 784 C Calculate SC interaction energy.
 785 C
 786         do iint=1,nint_gr(i)
 787           do j=istart(i,iint),iend(i,iint)
 788             ind=ind+1
 789             itypj=iabs(itype(j))
 790             if (itypj.eq.ntyp1) cycle
 791             dscj_inv=vbld_inv(j+nres)
 792             chi1=chi(itypi,itypj)
 793             chi2=chi(itypj,itypi)
 794             chi12=chi1*chi2
 795             chip1=chip(itypi)
 796             chip2=chip(itypj)
 797             chip12=chip1*chip2
 798             alf1=alp(itypi)
 799             alf2=alp(itypj)
 800             alf12=0.5D0*(alf1+alf2)
 801 C For diagnostics only!!!
 802 c           chi1=0.0D0
 803 c           chi2=0.0D0
 804 c           chi12=0.0D0
 805 c           chip1=0.0D0
 806 c           chip2=0.0D0
 807 c           chip12=0.0D0
 808 c           alf1=0.0D0
 809 c           alf2=0.0D0
 810 c           alf12=0.0D0
 811             xj=c(1,nres+j)-xi
 812             yj=c(2,nres+j)-yi
 813             zj=c(3,nres+j)-zi
 814             dxj=dc_norm(1,nres+j)
 815             dyj=dc_norm(2,nres+j)
 816             dzj=dc_norm(3,nres+j)
 817             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 818 cd          if (icall.eq.0) then
 819 cd            rrsave(ind)=rrij
 820 cd          else
 821 cd            rrij=rrsave(ind)
 822 cd          endif
 823             rij=dsqrt(rrij)
 824 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 825             call sc_angular
 826 C Calculate whole angle-dependent part of epsilon and contributions
 827 C to its derivatives
 828             fac=(rrij*sigsq)**expon2
 829             e1=fac*fac*aa
 830             e2=fac*bb
 831             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 832             eps2der=evdwij*eps3rt
 833             eps3der=evdwij*eps2rt
 834             evdwij=evdwij*eps2rt*eps3rt
 835             ij=icant(itypi,itypj)
 836             aux=eps1*eps2rt**2*eps3rt**2
 837             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 838      &        /dabs(eps(itypi,itypj))
 839             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 840             if (bb.gt.0.0d0) then
 841               evdw=evdw+evdwij
 842             else
 843               evdw_t=evdw_t+evdwij
 844             endif
 845             if (calc_grad) then
 846             if (lprn) then
 847             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 848             epsi=bb**2/aa
 849             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 850      &        restyp(itypi),i,restyp(itypj),j,
 851      &        epsi,sigm,chi1,chi2,chip1,chip2,
 852      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 853      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 854      &        evdwij
 855             endif
 856 C Calculate gradient components.
 857             e1=e1*eps1*eps2rt**2*eps3rt**2
 858             fac=-expon*(e1+evdwij)
 859             sigder=fac/sigsq
 860             fac=rrij*fac
 861 C Calculate radial part of the gradient
 862             gg(1)=xj*fac
 863             gg(2)=yj*fac
 864             gg(3)=zj*fac
 865 C Calculate the angular part of the gradient and sum add the contributions
 866 C to the appropriate components of the Cartesian gradient.
 867             call sc_grad
 868             endif
 869           enddo      ! j
 870         enddo        ! iint
 871       enddo          ! i
 872 c     stop
 873       return
 874       end
 875 C-----------------------------------------------------------------------------
 876       subroutine egb(evdw,evdw_t)
 877 C
 878 C This subroutine calculates the interaction energy of nonbonded side chains
 879 C assuming the Gay-Berne potential of interaction.
 880 C
 881       implicit real*8 (a-h,o-z)
 882       include 'DIMENSIONS'
 883       include 'DIMENSIONS.ZSCOPT'
 884       include "DIMENSIONS.COMPAR"
 885       include 'COMMON.GEO'
 886       include 'COMMON.VAR'
 887       include 'COMMON.LOCAL'
 888       include 'COMMON.CHAIN'
 889       include 'COMMON.DERIV'
 890       include 'COMMON.NAMES'
 891       include 'COMMON.INTERACT'
 892       include 'COMMON.ENEPS'
 893       include 'COMMON.IOUNITS'
 894       include 'COMMON.CALC'
 895       include 'COMMON.SBRIDGE'
 896       logical lprn
 897       common /srutu/icall
 898       integer icant
 899       external icant
 900       do i=1,210
 901         do j=1,2
 902           eneps_temp(j,i)=0.0d0
 903         enddo
 904       enddo
 905 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 906       evdw=0.0D0
 907       evdw_t=0.0d0
 908       lprn=.false.
 909 c      if (icall.gt.0) lprn=.true.
 910       ind=0
 911       do i=iatsc_s,iatsc_e
 912         itypi=iabs(itype(i))
 913         if (itypi.eq.ntyp1) cycle
 914         itypi1=iabs(itype(i+1))
 915         xi=c(1,nres+i)
 916         yi=c(2,nres+i)
 917         zi=c(3,nres+i)
 918 C returning the ith atom to box
 919           xi=mod(xi,boxxsize)
 920           if (xi.lt.0) xi=xi+boxxsize
 921           yi=mod(yi,boxysize)
 922           if (yi.lt.0) yi=yi+boxysize
 923           zi=mod(zi,boxzsize)
 924           if (zi.lt.0) zi=zi+boxzsize
 925        if ((zi.gt.bordlipbot)
 926      &.and.(zi.lt.bordliptop)) then
 927 C the energy transfer exist
 928         if (zi.lt.buflipbot) then
 929 C what fraction I am in
 930          fracinbuf=1.0d0-
 931      &        ((zi-bordlipbot)/lipbufthick)
 932 C lipbufthick is thickenes of lipid buffore
 933          sslipi=sscalelip(fracinbuf)
 934          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 935         elseif (zi.gt.bufliptop) then
 936          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 937          sslipi=sscalelip(fracinbuf)
 938          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 939         else
 940          sslipi=1.0d0
 941          ssgradlipi=0.0
 942         endif
 943        else
 944          sslipi=0.0d0
 945          ssgradlipi=0.0
 946        endif
 947
 948         dxi=dc_norm(1,nres+i)
 949         dyi=dc_norm(2,nres+i)
 950         dzi=dc_norm(3,nres+i)
 951         dsci_inv=vbld_inv(i+nres)
 952 C
 953 C Calculate SC interaction energy.
 954 C
 955         do iint=1,nint_gr(i)
 956           do j=istart(i,iint),iend(i,iint)
 957             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 958               call dyn_ssbond_ene(i,j,evdwij)
 959               evdw=evdw+evdwij
 960 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 961 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
 962 C triple bond artifac removal
 963              do k=j+1,iend(i,iint)
 964 C search over all next residues
 965               if (dyn_ss_mask(k)) then
 966 C check if they are cysteins
 967 C              write(iout,*) 'k=',k
 968               call triple_ssbond_ene(i,j,k,evdwij)
 969 C call the energy function that removes the artifical triple disulfide
 970 C bond the soubroutine is located in ssMD.F
 971               evdw=evdw+evdwij
 972 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 973 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
 974               endif!dyn_ss_mask(k)
 975              enddo! k
 976             ELSE
 977             ind=ind+1
 978             itypj=iabs(itype(j))
 979             if (itypj.eq.ntyp1) cycle
 980             dscj_inv=vbld_inv(j+nres)
 981             sig0ij=sigma(itypi,itypj)
 982             chi1=chi(itypi,itypj)
 983             chi2=chi(itypj,itypi)
 984             chi12=chi1*chi2
 985             chip1=chip(itypi)
 986             chip2=chip(itypj)
 987             chip12=chip1*chip2
 988             alf1=alp(itypi)
 989             alf2=alp(itypj)
 990             alf12=0.5D0*(alf1+alf2)
 991 C For diagnostics only!!!
 992 c           chi1=0.0D0
 993 c           chi2=0.0D0
 994 c           chi12=0.0D0
 995 c           chip1=0.0D0
 996 c           chip2=0.0D0
 997 c           chip12=0.0D0
 998 c           alf1=0.0D0
 999 c           alf2=0.0D0
1000 c           alf12=0.0D0
1001             xj=c(1,nres+j)
1002             yj=c(2,nres+j)
1003             zj=c(3,nres+j)
1004 C returning jth atom to box
1005           xj=mod(xj,boxxsize)
1006           if (xj.lt.0) xj=xj+boxxsize
1007           yj=mod(yj,boxysize)
1008           if (yj.lt.0) yj=yj+boxysize
1009           zj=mod(zj,boxzsize)
1010           if (zj.lt.0) zj=zj+boxzsize
1011        if ((zj.gt.bordlipbot)
1012      &.and.(zj.lt.bordliptop)) then
1013 C the energy transfer exist
1014         if (zj.lt.buflipbot) then
1015 C what fraction I am in
1016          fracinbuf=1.0d0-
1017      &        ((zj-bordlipbot)/lipbufthick)
1018 C lipbufthick is thickenes of lipid buffore
1019          sslipj=sscalelip(fracinbuf)
1020          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1021         elseif (zj.gt.bufliptop) then
1022          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1023          sslipj=sscalelip(fracinbuf)
1024          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1025         else
1026          sslipj=1.0d0
1027          ssgradlipj=0.0
1028         endif
1029        else
1030          sslipj=0.0d0
1031          ssgradlipj=0.0
1032        endif
1033       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1034      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1035       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1036      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1037 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1038 C checking the distance
1039       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1040       xj_safe=xj
1041       yj_safe=yj
1042       zj_safe=zj
1043       subchap=0
1044 C finding the closest
1045       do xshift=-1,1
1046       do yshift=-1,1
1047       do zshift=-1,1
1048           xj=xj_safe+xshift*boxxsize
1049           yj=yj_safe+yshift*boxysize
1050           zj=zj_safe+zshift*boxzsize
1051           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1052           if(dist_temp.lt.dist_init) then
1053             dist_init=dist_temp
1054             xj_temp=xj
1055             yj_temp=yj
1056             zj_temp=zj
1057             subchap=1
1058           endif
1059        enddo
1060        enddo
1061        enddo
1062        if (subchap.eq.1) then
1063           xj=xj_temp-xi
1064           yj=yj_temp-yi
1065           zj=zj_temp-zi
1066        else
1067           xj=xj_safe-xi
1068           yj=yj_safe-yi
1069           zj=zj_safe-zi
1070        endif
1071
1072             dxj=dc_norm(1,nres+j)
1073             dyj=dc_norm(2,nres+j)
1074             dzj=dc_norm(3,nres+j)
1075 c            write (iout,*) i,j,xj,yj,zj
1076             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1077             rij=dsqrt(rrij)
1078             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1079             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1080             if (sss.le.0.0) cycle
1081 C Calculate angle-dependent terms of energy and contributions to their
1082 C derivatives.
1083
1084             call sc_angular
1085             sigsq=1.0D0/sigsq
1086             sig=sig0ij*dsqrt(sigsq)
1087             rij_shift=1.0D0/rij-sig+sig0ij
1088 C I hate to put IF's in the loops, but here don't have another choice!!!!
1089             if (rij_shift.le.0.0D0) then
1090               evdw=1.0D20
1091               return
1092             endif
1093             sigder=-sig*sigsq
1094 c---------------------------------------------------------------
1095             rij_shift=1.0D0/rij_shift
1096             fac=rij_shift**expon
1097             e1=fac*fac*aa
1098             e2=fac*bb
1099             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1100             eps2der=evdwij*eps3rt
1101             eps3der=evdwij*eps2rt
1102             evdwij=evdwij*eps2rt*eps3rt
1103             if (bb.gt.0) then
1104               evdw=evdw+evdwij*sss
1105             else
1106               evdw_t=evdw_t+evdwij*sss
1107             endif
1108             ij=icant(itypi,itypj)
1109             aux=eps1*eps2rt**2*eps3rt**2
1110             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1111      &        /dabs(eps(itypi,itypj))
1112             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1113 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1114 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1115 c     &         aux*e2/eps(itypi,itypj)
1116 c            if (lprn) then
1117             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1118             epsi=bb**2/aa
1119 #ifdef DEBUG
1120             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1121      &        restyp(itypi),i,restyp(itypj),j,
1122      &        epsi,sigm,chi1,chi2,chip1,chip2,
1123      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1124      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1125      &        evdwij
1126              write (iout,*) "partial sum", evdw, evdw_t
1127 #endif
1128 c            endif
1129             if (calc_grad) then
1130 C Calculate gradient components.
1131             e1=e1*eps1*eps2rt**2*eps3rt**2
1132             fac=-expon*(e1+evdwij)*rij_shift
1133             sigder=fac*sigder
1134             fac=rij*fac
1135             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1136 C Calculate the radial part of the gradient
1137             gg(1)=xj*fac
1138             gg(2)=yj*fac
1139             gg(3)=zj*fac
1140 C Calculate angular part of the gradient.
1141             call sc_grad
1142             endif
1143 C            write(iout,*)  "partial sum", evdw, evdw_t
1144             ENDIF    ! dyn_ss
1145           enddo      ! j
1146         enddo        ! iint
1147       enddo          ! i
1148       return
1149       end
1150 C-----------------------------------------------------------------------------
1151       subroutine egbv(evdw,evdw_t)
1152 C
1153 C This subroutine calculates the interaction energy of nonbonded side chains
1154 C assuming the Gay-Berne-Vorobjev potential of interaction.
1155 C
1156       implicit real*8 (a-h,o-z)
1157       include 'DIMENSIONS'
1158       include 'DIMENSIONS.ZSCOPT'
1159       include "DIMENSIONS.COMPAR"
1160       include 'COMMON.GEO'
1161       include 'COMMON.VAR'
1162       include 'COMMON.LOCAL'
1163       include 'COMMON.CHAIN'
1164       include 'COMMON.DERIV'
1165       include 'COMMON.NAMES'
1166       include 'COMMON.INTERACT'
1167       include 'COMMON.ENEPS'
1168       include 'COMMON.IOUNITS'
1169       include 'COMMON.CALC'
1170       common /srutu/ icall
1171       logical lprn
1172       integer icant
1173       external icant
1174       do i=1,210
1175         do j=1,2
1176           eneps_temp(j,i)=0.0d0
1177         enddo
1178       enddo
1179       evdw=0.0D0
1180       evdw_t=0.0d0
1181 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1182       evdw=0.0D0
1183       lprn=.false.
1184 c      if (icall.gt.0) lprn=.true.
1185       ind=0
1186       do i=iatsc_s,iatsc_e
1187         itypi=iabs(itype(i))
1188         if (itypi.eq.ntyp1) cycle
1189         itypi1=iabs(itype(i+1))
1190         xi=c(1,nres+i)
1191         yi=c(2,nres+i)
1192         zi=c(3,nres+i)
1193         dxi=dc_norm(1,nres+i)
1194         dyi=dc_norm(2,nres+i)
1195         dzi=dc_norm(3,nres+i)
1196         dsci_inv=vbld_inv(i+nres)
1197 C
1198 C Calculate SC interaction energy.
1199 C
1200         do iint=1,nint_gr(i)
1201           do j=istart(i,iint),iend(i,iint)
1202             ind=ind+1
1203             itypj=iabs(itype(j))
1204             if (itypj.eq.ntyp1) cycle
1205             dscj_inv=vbld_inv(j+nres)
1206             sig0ij=sigma(itypi,itypj)
1207             r0ij=r0(itypi,itypj)
1208             chi1=chi(itypi,itypj)
1209             chi2=chi(itypj,itypi)
1210             chi12=chi1*chi2
1211             chip1=chip(itypi)
1212             chip2=chip(itypj)
1213             chip12=chip1*chip2
1214             alf1=alp(itypi)
1215             alf2=alp(itypj)
1216             alf12=0.5D0*(alf1+alf2)
1217 C For diagnostics only!!!
1218 c           chi1=0.0D0
1219 c           chi2=0.0D0
1220 c           chi12=0.0D0
1221 c           chip1=0.0D0
1222 c           chip2=0.0D0
1223 c           chip12=0.0D0
1224 c           alf1=0.0D0
1225 c           alf2=0.0D0
1226 c           alf12=0.0D0
1227             xj=c(1,nres+j)-xi
1228             yj=c(2,nres+j)-yi
1229             zj=c(3,nres+j)-zi
1230             dxj=dc_norm(1,nres+j)
1231             dyj=dc_norm(2,nres+j)
1232             dzj=dc_norm(3,nres+j)
1233             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1234             rij=dsqrt(rrij)
1235 C Calculate angle-dependent terms of energy and contributions to their
1236 C derivatives.
1237             call sc_angular
1238             sigsq=1.0D0/sigsq
1239             sig=sig0ij*dsqrt(sigsq)
1240             rij_shift=1.0D0/rij-sig+r0ij
1241 C I hate to put IF's in the loops, but here don't have another choice!!!!
1242             if (rij_shift.le.0.0D0) then
1243               evdw=1.0D20
1244               return
1245             endif
1246             sigder=-sig*sigsq
1247 c---------------------------------------------------------------
1248             rij_shift=1.0D0/rij_shift
1249             fac=rij_shift**expon
1250             e1=fac*fac*aa
1251             e2=fac*bb
1252             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1253             eps2der=evdwij*eps3rt
1254             eps3der=evdwij*eps2rt
1255             fac_augm=rrij**expon
1256             e_augm=augm(itypi,itypj)*fac_augm
1257             evdwij=evdwij*eps2rt*eps3rt
1258             if (bb.gt.0.0d0) then
1259               evdw=evdw+evdwij+e_augm
1260             else
1261               evdw_t=evdw_t+evdwij+e_augm
1262             endif
1263             ij=icant(itypi,itypj)
1264             aux=eps1*eps2rt**2*eps3rt**2
1265             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1266      &        /dabs(eps(itypi,itypj))
1267             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1268 c            eneps_temp(ij)=eneps_temp(ij)
1269 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1270 c            if (lprn) then
1271 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1272 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1273 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1274 c     &        restyp(itypi),i,restyp(itypj),j,
1275 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1276 c     &        chi1,chi2,chip1,chip2,
1277 c     &        eps1,eps2rt**2,eps3rt**2,
1278 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1279 c     &        evdwij+e_augm
1280 c            endif
1281             if (calc_grad) then
1282 C Calculate gradient components.
1283             e1=e1*eps1*eps2rt**2*eps3rt**2
1284             fac=-expon*(e1+evdwij)*rij_shift
1285             sigder=fac*sigder
1286             fac=rij*fac-2*expon*rrij*e_augm
1287 C Calculate the radial part of the gradient
1288             gg(1)=xj*fac
1289             gg(2)=yj*fac
1290             gg(3)=zj*fac
1291 C Calculate angular part of the gradient.
1292             call sc_grad
1293             endif
1294           enddo      ! j
1295         enddo        ! iint
1296       enddo          ! i
1297       return
1298       end
1299 C-----------------------------------------------------------------------------
1300       subroutine sc_angular
1301 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1302 C om12. Called by ebp, egb, and egbv.
1303       implicit none
1304       include 'COMMON.CALC'
1305       erij(1)=xj*rij
1306       erij(2)=yj*rij
1307       erij(3)=zj*rij
1308       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1309       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1310       om12=dxi*dxj+dyi*dyj+dzi*dzj
1311       chiom12=chi12*om12
1312 C Calculate eps1(om12) and its derivative in om12
1313       faceps1=1.0D0-om12*chiom12
1314       faceps1_inv=1.0D0/faceps1
1315       eps1=dsqrt(faceps1_inv)
1316 C Following variable is eps1*deps1/dom12
1317       eps1_om12=faceps1_inv*chiom12
1318 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1319 C and om12.
1320       om1om2=om1*om2
1321       chiom1=chi1*om1
1322       chiom2=chi2*om2
1323       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1324       sigsq=1.0D0-facsig*faceps1_inv
1325       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1326       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1327       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1328 C Calculate eps2 and its derivatives in om1, om2, and om12.
1329       chipom1=chip1*om1
1330       chipom2=chip2*om2
1331       chipom12=chip12*om12
1332       facp=1.0D0-om12*chipom12
1333       facp_inv=1.0D0/facp
1334       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1335 C Following variable is the square root of eps2
1336       eps2rt=1.0D0-facp1*facp_inv
1337 C Following three variables are the derivatives of the square root of eps
1338 C in om1, om2, and om12.
1339       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1340       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1341       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1342 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1343       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1344 C Calculate whole angle-dependent part of epsilon and contributions
1345 C to its derivatives
1346       return
1347       end
1348 C----------------------------------------------------------------------------
1349       subroutine sc_grad
1350       implicit real*8 (a-h,o-z)
1351       include 'DIMENSIONS'
1352       include 'DIMENSIONS.ZSCOPT'
1353       include 'COMMON.CHAIN'
1354       include 'COMMON.DERIV'
1355       include 'COMMON.CALC'
1356       double precision dcosom1(3),dcosom2(3)
1357       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1358       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1359       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1360      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1361       do k=1,3
1362         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1363         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1364       enddo
1365       do k=1,3
1366         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1367       enddo
1368       do k=1,3
1369         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1370      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1371      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1372         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1373      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1374      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1375       enddo
1376 C
1377 C Calculate the components of the gradient in DC and X
1378 C
1379       do k=i,j-1
1380         do l=1,3
1381           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1382         enddo
1383       enddo
1384       return
1385       end
1386 c------------------------------------------------------------------------------
1387       subroutine vec_and_deriv
1388       implicit real*8 (a-h,o-z)
1389       include 'DIMENSIONS'
1390       include 'DIMENSIONS.ZSCOPT'
1391       include 'COMMON.IOUNITS'
1392       include 'COMMON.GEO'
1393       include 'COMMON.VAR'
1394       include 'COMMON.LOCAL'
1395       include 'COMMON.CHAIN'
1396       include 'COMMON.VECTORS'
1397       include 'COMMON.DERIV'
1398       include 'COMMON.INTERACT'
1399       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1400 C Compute the local reference systems. For reference system (i), the
1401 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1402 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1403       do i=1,nres-1
1404 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1405           if (i.eq.nres-1) then
1406 C Case of the last full residue
1407 C Compute the Z-axis
1408             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1409             costh=dcos(pi-theta(nres))
1410             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1411             do k=1,3
1412               uz(k,i)=fac*uz(k,i)
1413             enddo
1414             if (calc_grad) then
1415 C Compute the derivatives of uz
1416             uzder(1,1,1)= 0.0d0
1417             uzder(2,1,1)=-dc_norm(3,i-1)
1418             uzder(3,1,1)= dc_norm(2,i-1)
1419             uzder(1,2,1)= dc_norm(3,i-1)
1420             uzder(2,2,1)= 0.0d0
1421             uzder(3,2,1)=-dc_norm(1,i-1)
1422             uzder(1,3,1)=-dc_norm(2,i-1)
1423             uzder(2,3,1)= dc_norm(1,i-1)
1424             uzder(3,3,1)= 0.0d0
1425             uzder(1,1,2)= 0.0d0
1426             uzder(2,1,2)= dc_norm(3,i)
1427             uzder(3,1,2)=-dc_norm(2,i)
1428             uzder(1,2,2)=-dc_norm(3,i)
1429             uzder(2,2,2)= 0.0d0
1430             uzder(3,2,2)= dc_norm(1,i)
1431             uzder(1,3,2)= dc_norm(2,i)
1432             uzder(2,3,2)=-dc_norm(1,i)
1433             uzder(3,3,2)= 0.0d0
1434             endif
1435 C Compute the Y-axis
1436             facy=fac
1437             do k=1,3
1438               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1439             enddo
1440             if (calc_grad) then
1441 C Compute the derivatives of uy
1442             do j=1,3
1443               do k=1,3
1444                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1445      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1446                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1447               enddo
1448               uyder(j,j,1)=uyder(j,j,1)-costh
1449               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1450             enddo
1451             do j=1,2
1452               do k=1,3
1453                 do l=1,3
1454                   uygrad(l,k,j,i)=uyder(l,k,j)
1455                   uzgrad(l,k,j,i)=uzder(l,k,j)
1456                 enddo
1457               enddo
1458             enddo
1459             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1460             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1461             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1462             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1463             endif
1464           else
1465 C Other residues
1466 C Compute the Z-axis
1467             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1468             costh=dcos(pi-theta(i+2))
1469             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1470             do k=1,3
1471               uz(k,i)=fac*uz(k,i)
1472             enddo
1473             if (calc_grad) then
1474 C Compute the derivatives of uz
1475             uzder(1,1,1)= 0.0d0
1476             uzder(2,1,1)=-dc_norm(3,i+1)
1477             uzder(3,1,1)= dc_norm(2,i+1)
1478             uzder(1,2,1)= dc_norm(3,i+1)
1479             uzder(2,2,1)= 0.0d0
1480             uzder(3,2,1)=-dc_norm(1,i+1)
1481             uzder(1,3,1)=-dc_norm(2,i+1)
1482             uzder(2,3,1)= dc_norm(1,i+1)
1483             uzder(3,3,1)= 0.0d0
1484             uzder(1,1,2)= 0.0d0
1485             uzder(2,1,2)= dc_norm(3,i)
1486             uzder(3,1,2)=-dc_norm(2,i)
1487             uzder(1,2,2)=-dc_norm(3,i)
1488             uzder(2,2,2)= 0.0d0
1489             uzder(3,2,2)= dc_norm(1,i)
1490             uzder(1,3,2)= dc_norm(2,i)
1491             uzder(2,3,2)=-dc_norm(1,i)
1492             uzder(3,3,2)= 0.0d0
1493             endif
1494 C Compute the Y-axis
1495             facy=fac
1496             do k=1,3
1497               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1498             enddo
1499             if (calc_grad) then
1500 C Compute the derivatives of uy
1501             do j=1,3
1502               do k=1,3
1503                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1504      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1505                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1506               enddo
1507               uyder(j,j,1)=uyder(j,j,1)-costh
1508               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1509             enddo
1510             do j=1,2
1511               do k=1,3
1512                 do l=1,3
1513                   uygrad(l,k,j,i)=uyder(l,k,j)
1514                   uzgrad(l,k,j,i)=uzder(l,k,j)
1515                 enddo
1516               enddo
1517             enddo
1518             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1519             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1520             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1521             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1522           endif
1523           endif
1524       enddo
1525       if (calc_grad) then
1526       do i=1,nres-1
1527         vbld_inv_temp(1)=vbld_inv(i+1)
1528         if (i.lt.nres-1) then
1529           vbld_inv_temp(2)=vbld_inv(i+2)
1530         else
1531           vbld_inv_temp(2)=vbld_inv(i)
1532         endif
1533         do j=1,2
1534           do k=1,3
1535             do l=1,3
1536               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1537               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1538             enddo
1539           enddo
1540         enddo
1541       enddo
1542       endif
1543       return
1544       end
1545 C-----------------------------------------------------------------------------
1546       subroutine vec_and_deriv_test
1547       implicit real*8 (a-h,o-z)
1548       include 'DIMENSIONS'
1549       include 'DIMENSIONS.ZSCOPT'
1550       include 'COMMON.IOUNITS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.VECTORS'
1556       dimension uyder(3,3,2),uzder(3,3,2)
1557 C Compute the local reference systems. For reference system (i), the
1558 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1559 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1560       do i=1,nres-1
1561           if (i.eq.nres-1) then
1562 C Case of the last full residue
1563 C Compute the Z-axis
1564             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1565             costh=dcos(pi-theta(nres))
1566             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1567 c            write (iout,*) 'fac',fac,
1568 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1569             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1570             do k=1,3
1571               uz(k,i)=fac*uz(k,i)
1572             enddo
1573 C Compute the derivatives of uz
1574             uzder(1,1,1)= 0.0d0
1575             uzder(2,1,1)=-dc_norm(3,i-1)
1576             uzder(3,1,1)= dc_norm(2,i-1)
1577             uzder(1,2,1)= dc_norm(3,i-1)
1578             uzder(2,2,1)= 0.0d0
1579             uzder(3,2,1)=-dc_norm(1,i-1)
1580             uzder(1,3,1)=-dc_norm(2,i-1)
1581             uzder(2,3,1)= dc_norm(1,i-1)
1582             uzder(3,3,1)= 0.0d0
1583             uzder(1,1,2)= 0.0d0
1584             uzder(2,1,2)= dc_norm(3,i)
1585             uzder(3,1,2)=-dc_norm(2,i)
1586             uzder(1,2,2)=-dc_norm(3,i)
1587             uzder(2,2,2)= 0.0d0
1588             uzder(3,2,2)= dc_norm(1,i)
1589             uzder(1,3,2)= dc_norm(2,i)
1590             uzder(2,3,2)=-dc_norm(1,i)
1591             uzder(3,3,2)= 0.0d0
1592 C Compute the Y-axis
1593             do k=1,3
1594               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1595             enddo
1596             facy=fac
1597             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1598      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1599      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1600             do k=1,3
1601 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1602               uy(k,i)=
1603 c     &        facy*(
1604      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1605      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1606 c     &        )
1607             enddo
1608 c            write (iout,*) 'facy',facy,
1609 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1610             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1611             do k=1,3
1612               uy(k,i)=facy*uy(k,i)
1613             enddo
1614 C Compute the derivatives of uy
1615             do j=1,3
1616               do k=1,3
1617                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1618      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1619                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1620               enddo
1621 c              uyder(j,j,1)=uyder(j,j,1)-costh
1622 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1623               uyder(j,j,1)=uyder(j,j,1)
1624      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1625               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1626      &          +uyder(j,j,2)
1627             enddo
1628             do j=1,2
1629               do k=1,3
1630                 do l=1,3
1631                   uygrad(l,k,j,i)=uyder(l,k,j)
1632                   uzgrad(l,k,j,i)=uzder(l,k,j)
1633                 enddo
1634               enddo
1635             enddo
1636             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1637             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1638             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1639             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1640           else
1641 C Other residues
1642 C Compute the Z-axis
1643             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1644             costh=dcos(pi-theta(i+2))
1645             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1646             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1647             do k=1,3
1648               uz(k,i)=fac*uz(k,i)
1649             enddo
1650 C Compute the derivatives of uz
1651             uzder(1,1,1)= 0.0d0
1652             uzder(2,1,1)=-dc_norm(3,i+1)
1653             uzder(3,1,1)= dc_norm(2,i+1)
1654             uzder(1,2,1)= dc_norm(3,i+1)
1655             uzder(2,2,1)= 0.0d0
1656             uzder(3,2,1)=-dc_norm(1,i+1)
1657             uzder(1,3,1)=-dc_norm(2,i+1)
1658             uzder(2,3,1)= dc_norm(1,i+1)
1659             uzder(3,3,1)= 0.0d0
1660             uzder(1,1,2)= 0.0d0
1661             uzder(2,1,2)= dc_norm(3,i)
1662             uzder(3,1,2)=-dc_norm(2,i)
1663             uzder(1,2,2)=-dc_norm(3,i)
1664             uzder(2,2,2)= 0.0d0
1665             uzder(3,2,2)= dc_norm(1,i)
1666             uzder(1,3,2)= dc_norm(2,i)
1667             uzder(2,3,2)=-dc_norm(1,i)
1668             uzder(3,3,2)= 0.0d0
1669 C Compute the Y-axis
1670             facy=fac
1671             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1672      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1673      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1674             do k=1,3
1675 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1676               uy(k,i)=
1677 c     &        facy*(
1678      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1679      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1680 c     &        )
1681             enddo
1682 c            write (iout,*) 'facy',facy,
1683 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1684             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1685             do k=1,3
1686               uy(k,i)=facy*uy(k,i)
1687             enddo
1688 C Compute the derivatives of uy
1689             do j=1,3
1690               do k=1,3
1691                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1692      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1693                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1694               enddo
1695 c              uyder(j,j,1)=uyder(j,j,1)-costh
1696 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1697               uyder(j,j,1)=uyder(j,j,1)
1698      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1699               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1700      &          +uyder(j,j,2)
1701             enddo
1702             do j=1,2
1703               do k=1,3
1704                 do l=1,3
1705                   uygrad(l,k,j,i)=uyder(l,k,j)
1706                   uzgrad(l,k,j,i)=uzder(l,k,j)
1707                 enddo
1708               enddo
1709             enddo
1710             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1711             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1712             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1713             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1714           endif
1715       enddo
1716       do i=1,nres-1
1717         do j=1,2
1718           do k=1,3
1719             do l=1,3
1720               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1721               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1722             enddo
1723           enddo
1724         enddo
1725       enddo
1726       return
1727       end
1728 C-----------------------------------------------------------------------------
1729       subroutine check_vecgrad
1730       implicit real*8 (a-h,o-z)
1731       include 'DIMENSIONS'
1732       include 'DIMENSIONS.ZSCOPT'
1733       include 'COMMON.IOUNITS'
1734       include 'COMMON.GEO'
1735       include 'COMMON.VAR'
1736       include 'COMMON.LOCAL'
1737       include 'COMMON.CHAIN'
1738       include 'COMMON.VECTORS'
1739       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1740       dimension uyt(3,maxres),uzt(3,maxres)
1741       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1742       double precision delta /1.0d-7/
1743       call vec_and_deriv
1744 cd      do i=1,nres
1745 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1746 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1747 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1748 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1749 cd     &     (dc_norm(if90,i),if90=1,3)
1750 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1751 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1752 cd          write(iout,'(a)')
1753 cd      enddo
1754       do i=1,nres
1755         do j=1,2
1756           do k=1,3
1757             do l=1,3
1758               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1759               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1760             enddo
1761           enddo
1762         enddo
1763       enddo
1764       call vec_and_deriv
1765       do i=1,nres
1766         do j=1,3
1767           uyt(j,i)=uy(j,i)
1768           uzt(j,i)=uz(j,i)
1769         enddo
1770       enddo
1771       do i=1,nres
1772 cd        write (iout,*) 'i=',i
1773         do k=1,3
1774           erij(k)=dc_norm(k,i)
1775         enddo
1776         do j=1,3
1777           do k=1,3
1778             dc_norm(k,i)=erij(k)
1779           enddo
1780           dc_norm(j,i)=dc_norm(j,i)+delta
1781 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1782 c          do k=1,3
1783 c            dc_norm(k,i)=dc_norm(k,i)/fac
1784 c          enddo
1785 c          write (iout,*) (dc_norm(k,i),k=1,3)
1786 c          write (iout,*) (erij(k),k=1,3)
1787           call vec_and_deriv
1788           do k=1,3
1789             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1790             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1791             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1792             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1793           enddo
1794 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1795 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1796 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1797         enddo
1798         do k=1,3
1799           dc_norm(k,i)=erij(k)
1800         enddo
1801 cd        do k=1,3
1802 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1803 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1804 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1805 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1806 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1807 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1808 cd          write (iout,'(a)')
1809 cd        enddo
1810       enddo
1811       return
1812       end
1813 C--------------------------------------------------------------------------
1814       subroutine set_matrices
1815       implicit real*8 (a-h,o-z)
1816       include 'DIMENSIONS'
1817       include 'DIMENSIONS.ZSCOPT'
1818       include 'COMMON.IOUNITS'
1819       include 'COMMON.GEO'
1820       include 'COMMON.VAR'
1821       include 'COMMON.LOCAL'
1822       include 'COMMON.CHAIN'
1823       include 'COMMON.DERIV'
1824       include 'COMMON.INTERACT'
1825       include 'COMMON.CONTACTS'
1826       include 'COMMON.TORSION'
1827       include 'COMMON.VECTORS'
1828       include 'COMMON.FFIELD'
1829       double precision auxvec(2),auxmat(2,2)
1830 C
1831 C Compute the virtual-bond-torsional-angle dependent quantities needed
1832 C to calculate the el-loc multibody terms of various order.
1833 C
1834       do i=3,nres+1
1835         if (i .lt. nres+1) then
1836           sin1=dsin(phi(i))
1837           cos1=dcos(phi(i))
1838           sintab(i-2)=sin1
1839           costab(i-2)=cos1
1840           obrot(1,i-2)=cos1
1841           obrot(2,i-2)=sin1
1842           sin2=dsin(2*phi(i))
1843           cos2=dcos(2*phi(i))
1844           sintab2(i-2)=sin2
1845           costab2(i-2)=cos2
1846           obrot2(1,i-2)=cos2
1847           obrot2(2,i-2)=sin2
1848           Ug(1,1,i-2)=-cos1
1849           Ug(1,2,i-2)=-sin1
1850           Ug(2,1,i-2)=-sin1
1851           Ug(2,2,i-2)= cos1
1852           Ug2(1,1,i-2)=-cos2
1853           Ug2(1,2,i-2)=-sin2
1854           Ug2(2,1,i-2)=-sin2
1855           Ug2(2,2,i-2)= cos2
1856         else
1857           costab(i-2)=1.0d0
1858           sintab(i-2)=0.0d0
1859           obrot(1,i-2)=1.0d0
1860           obrot(2,i-2)=0.0d0
1861           obrot2(1,i-2)=0.0d0
1862           obrot2(2,i-2)=0.0d0
1863           Ug(1,1,i-2)=1.0d0
1864           Ug(1,2,i-2)=0.0d0
1865           Ug(2,1,i-2)=0.0d0
1866           Ug(2,2,i-2)=1.0d0
1867           Ug2(1,1,i-2)=0.0d0
1868           Ug2(1,2,i-2)=0.0d0
1869           Ug2(2,1,i-2)=0.0d0
1870           Ug2(2,2,i-2)=0.0d0
1871         endif
1872         if (i .gt. 3 .and. i .lt. nres+1) then
1873           obrot_der(1,i-2)=-sin1
1874           obrot_der(2,i-2)= cos1
1875           Ugder(1,1,i-2)= sin1
1876           Ugder(1,2,i-2)=-cos1
1877           Ugder(2,1,i-2)=-cos1
1878           Ugder(2,2,i-2)=-sin1
1879           dwacos2=cos2+cos2
1880           dwasin2=sin2+sin2
1881           obrot2_der(1,i-2)=-dwasin2
1882           obrot2_der(2,i-2)= dwacos2
1883           Ug2der(1,1,i-2)= dwasin2
1884           Ug2der(1,2,i-2)=-dwacos2
1885           Ug2der(2,1,i-2)=-dwacos2
1886           Ug2der(2,2,i-2)=-dwasin2
1887         else
1888           obrot_der(1,i-2)=0.0d0
1889           obrot_der(2,i-2)=0.0d0
1890           Ugder(1,1,i-2)=0.0d0
1891           Ugder(1,2,i-2)=0.0d0
1892           Ugder(2,1,i-2)=0.0d0
1893           Ugder(2,2,i-2)=0.0d0
1894           obrot2_der(1,i-2)=0.0d0
1895           obrot2_der(2,i-2)=0.0d0
1896           Ug2der(1,1,i-2)=0.0d0
1897           Ug2der(1,2,i-2)=0.0d0
1898           Ug2der(2,1,i-2)=0.0d0
1899           Ug2der(2,2,i-2)=0.0d0
1900         endif
1901         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1902           if (itype(i-2).le.ntyp) then
1903             iti = itortyp(itype(i-2))
1904           else
1905             iti=ntortyp+1
1906           endif
1907         else
1908           iti=ntortyp+1
1909         endif
1910         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1911           if (itype(i-1).le.ntyp) then
1912             iti1 = itortyp(itype(i-1))
1913           else
1914             iti1=ntortyp+1
1915           endif
1916         else
1917           iti1=ntortyp+1
1918         endif
1919 cd        write (iout,*) '*******i',i,' iti1',iti
1920 cd        write (iout,*) 'b1',b1(:,iti)
1921 cd        write (iout,*) 'b2',b2(:,iti)
1922 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1923 c        print *,"itilde1 i iti iti1",i,iti,iti1
1924         if (i .gt. iatel_s+2) then
1925           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1926           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1927           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1928           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1929           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1930           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1931           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1932         else
1933           do k=1,2
1934             Ub2(k,i-2)=0.0d0
1935             Ctobr(k,i-2)=0.0d0
1936             Dtobr2(k,i-2)=0.0d0
1937             do l=1,2
1938               EUg(l,k,i-2)=0.0d0
1939               CUg(l,k,i-2)=0.0d0
1940               DUg(l,k,i-2)=0.0d0
1941               DtUg2(l,k,i-2)=0.0d0
1942             enddo
1943           enddo
1944         endif
1945 c        print *,"itilde2 i iti iti1",i,iti,iti1
1946         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1947         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1948         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1949         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1950         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1951         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1952         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1953 c        print *,"itilde3 i iti iti1",i,iti,iti1
1954         do k=1,2
1955           muder(k,i-2)=Ub2der(k,i-2)
1956         enddo
1957         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1958           if (itype(i-1).le.ntyp) then
1959             iti1 = itortyp(itype(i-1))
1960           else
1961             iti1=ntortyp+1
1962           endif
1963         else
1964           iti1=ntortyp+1
1965         endif
1966         do k=1,2
1967           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1968         enddo
1969 C        write (iout,*) 'mumu',i,b1(1,iti),Ub2(1,i-2)
1970
1971 C Vectors and matrices dependent on a single virtual-bond dihedral.
1972         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1973         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1974         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1975         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1976         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1977         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1978         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1979         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1980         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1981 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1982 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1983       enddo
1984 C Matrices dependent on two consecutive virtual-bond dihedrals.
1985 C The order of matrices is from left to right.
1986       do i=2,nres-1
1987         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1988         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1989         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1990         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1991         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1992         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1993         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1994         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1995       enddo
1996 cd      do i=1,nres
1997 cd        iti = itortyp(itype(i))
1998 cd        write (iout,*) i
1999 cd        do j=1,2
2000 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2001 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2002 cd        enddo
2003 cd      enddo
2004       return
2005       end
2006 C--------------------------------------------------------------------------
2007       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2008 C
2009 C This subroutine calculates the average interaction energy and its gradient
2010 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2011 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2012 C The potential depends both on the distance of peptide-group centers and on
2013 C the orientation of the CA-CA virtual bonds.
2014 C
2015       implicit real*8 (a-h,o-z)
2016       include 'DIMENSIONS'
2017       include 'DIMENSIONS.ZSCOPT'
2018       include 'COMMON.CONTROL'
2019       include 'COMMON.IOUNITS'
2020       include 'COMMON.GEO'
2021       include 'COMMON.VAR'
2022       include 'COMMON.LOCAL'
2023       include 'COMMON.CHAIN'
2024       include 'COMMON.DERIV'
2025       include 'COMMON.INTERACT'
2026       include 'COMMON.CONTACTS'
2027       include 'COMMON.TORSION'
2028       include 'COMMON.VECTORS'
2029       include 'COMMON.FFIELD'
2030       include 'COMMON.SHIELD'
2031       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2032      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2033       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2034      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2035       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2036 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2037       double precision scal_el /0.5d0/
2038 C 12/13/98
2039 C 13-go grudnia roku pamietnego...
2040       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2041      &                   0.0d0,1.0d0,0.0d0,
2042      &                   0.0d0,0.0d0,1.0d0/
2043 cd      write(iout,*) 'In EELEC'
2044 cd      do i=1,nloctyp
2045 cd        write(iout,*) 'Type',i
2046 cd        write(iout,*) 'B1',B1(:,i)
2047 cd        write(iout,*) 'B2',B2(:,i)
2048 cd        write(iout,*) 'CC',CC(:,:,i)
2049 cd        write(iout,*) 'DD',DD(:,:,i)
2050 cd        write(iout,*) 'EE',EE(:,:,i)
2051 cd      enddo
2052 cd      call check_vecgrad
2053 cd      stop
2054       if (icheckgrad.eq.1) then
2055         do i=1,nres-1
2056           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2057           do k=1,3
2058             dc_norm(k,i)=dc(k,i)*fac
2059           enddo
2060 c          write (iout,*) 'i',i,' fac',fac
2061         enddo
2062       endif
2063       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2064      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2065      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2066 cd      if (wel_loc.gt.0.0d0) then
2067         if (icheckgrad.eq.1) then
2068         call vec_and_deriv_test
2069         else
2070         call vec_and_deriv
2071         endif
2072         call set_matrices
2073       endif
2074 cd      do i=1,nres-1
2075 cd        write (iout,*) 'i=',i
2076 cd        do k=1,3
2077 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2078 cd        enddo
2079 cd        do k=1,3
2080 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2081 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2082 cd        enddo
2083 cd      enddo
2084       num_conti_hb=0
2085       ees=0.0D0
2086       evdw1=0.0D0
2087       eel_loc=0.0d0
2088       eello_turn3=0.0d0
2089       eello_turn4=0.0d0
2090       ind=0
2091       do i=1,nres
2092         num_cont_hb(i)=0
2093       enddo
2094 C      print '(a)','Enter EELEC'
2095 C      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2096       do i=1,nres
2097         gel_loc_loc(i)=0.0d0
2098         gcorr_loc(i)=0.0d0
2099       enddo
2100       do i=iatel_s,iatel_e
2101           if (i.eq.1) then
2102            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2103      &  .or. itype(i+2).eq.ntyp1) cycle
2104           else
2105         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2106      &  .or. itype(i+2).eq.ntyp1
2107      &  .or. itype(i-1).eq.ntyp1
2108      &) cycle
2109          endif
2110         if (itel(i).eq.0) goto 1215
2111         dxi=dc(1,i)
2112         dyi=dc(2,i)
2113         dzi=dc(3,i)
2114         dx_normi=dc_norm(1,i)
2115         dy_normi=dc_norm(2,i)
2116         dz_normi=dc_norm(3,i)
2117         xmedi=c(1,i)+0.5d0*dxi
2118         ymedi=c(2,i)+0.5d0*dyi
2119         zmedi=c(3,i)+0.5d0*dzi
2120           xmedi=mod(xmedi,boxxsize)
2121           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2122           ymedi=mod(ymedi,boxysize)
2123           if (ymedi.lt.0) ymedi=ymedi+boxysize
2124           zmedi=mod(zmedi,boxzsize)
2125           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2126         num_conti=0
2127 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2128         do j=ielstart(i),ielend(i)
2129           if (j.eq.1) then
2130            if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2131      & .or.itype(j+2).eq.ntyp1
2132      &) cycle
2133           else
2134           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2135      & .or.itype(j+2).eq.ntyp1
2136      & .or.itype(j-1).eq.ntyp1
2137      &) cycle
2138          endif
2139 C
2140 C) cycle
2141           if (itel(j).eq.0) goto 1216
2142           ind=ind+1
2143           iteli=itel(i)
2144           itelj=itel(j)
2145           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2146           aaa=app(iteli,itelj)
2147           bbb=bpp(iteli,itelj)
2148 C Diagnostics only!!!
2149 c         aaa=0.0D0
2150 c         bbb=0.0D0
2151 c         ael6i=0.0D0
2152 c         ael3i=0.0D0
2153 C End diagnostics
2154           ael6i=ael6(iteli,itelj)
2155           ael3i=ael3(iteli,itelj)
2156           dxj=dc(1,j)
2157           dyj=dc(2,j)
2158           dzj=dc(3,j)
2159           dx_normj=dc_norm(1,j)
2160           dy_normj=dc_norm(2,j)
2161           dz_normj=dc_norm(3,j)
2162           xj=c(1,j)+0.5D0*dxj
2163           yj=c(2,j)+0.5D0*dyj
2164           zj=c(3,j)+0.5D0*dzj
2165          xj=mod(xj,boxxsize)
2166           if (xj.lt.0) xj=xj+boxxsize
2167           yj=mod(yj,boxysize)
2168           if (yj.lt.0) yj=yj+boxysize
2169           zj=mod(zj,boxzsize)
2170           if (zj.lt.0) zj=zj+boxzsize
2171       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2172       xj_safe=xj
2173       yj_safe=yj
2174       zj_safe=zj
2175       isubchap=0
2176       do xshift=-1,1
2177       do yshift=-1,1
2178       do zshift=-1,1
2179           xj=xj_safe+xshift*boxxsize
2180           yj=yj_safe+yshift*boxysize
2181           zj=zj_safe+zshift*boxzsize
2182           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2183           if(dist_temp.lt.dist_init) then
2184             dist_init=dist_temp
2185             xj_temp=xj
2186             yj_temp=yj
2187             zj_temp=zj
2188             isubchap=1
2189           endif
2190        enddo
2191        enddo
2192        enddo
2193        if (isubchap.eq.1) then
2194           xj=xj_temp-xmedi
2195           yj=yj_temp-ymedi
2196           zj=zj_temp-zmedi
2197        else
2198           xj=xj_safe-xmedi
2199           yj=yj_safe-ymedi
2200           zj=zj_safe-zmedi
2201        endif
2202           rij=xj*xj+yj*yj+zj*zj
2203             sss=sscale(sqrt(rij))
2204             sssgrad=sscagrad(sqrt(rij))
2205           rrmij=1.0D0/rij
2206           rij=dsqrt(rij)
2207           rmij=1.0D0/rij
2208           r3ij=rrmij*rmij
2209           r6ij=r3ij*r3ij
2210           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2211           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2212           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2213           fac=cosa-3.0D0*cosb*cosg
2214           ev1=aaa*r6ij*r6ij
2215 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2216           if (j.eq.i+2) ev1=scal_el*ev1
2217           ev2=bbb*r6ij
2218           fac3=ael6i*r6ij
2219           fac4=ael3i*r3ij
2220           evdwij=ev1+ev2
2221           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2222           el2=fac4*fac
2223           eesij=el1+el2
2224 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2225 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2226           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2227           if (shield_mode.gt.0) then
2228 C          fac_shield(i)=0.4
2229 C          fac_shield(j)=0.6
2230           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2231           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2232           eesij=(el1+el2)
2233           ees=ees+eesij
2234           else
2235           fac_shield(i)=1.0
2236           fac_shield(j)=1.0
2237           eesij=(el1+el2)
2238           ees=ees+eesij
2239           endif
2240           evdw1=evdw1+evdwij*sss
2241 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2242 c     &'evdw1',i,j,evdwij
2243 c     &,iteli,itelj,aaa,evdw1
2244
2245 C              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2246 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2247 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2248 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2249 c     &      xmedi,ymedi,zmedi,xj,yj,zj
2250 C
2251 C Calculate contributions to the Cartesian gradient.
2252 C
2253 #ifdef SPLITELE
2254           facvdw=-6*rrmij*(ev1+evdwij)*sss
2255           facel=-3*rrmij*(el1+eesij)
2256           fac1=fac
2257           erij(1)=xj*rmij
2258           erij(2)=yj*rmij
2259           erij(3)=zj*rmij
2260           if (calc_grad) then
2261 *
2262 * Radial derivatives. First process both termini of the fragment (i,j)
2263 *
2264           ggg(1)=facel*xj
2265           ggg(2)=facel*yj
2266           ggg(3)=facel*zj
2267           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2268      &  (shield_mode.gt.0)) then
2269 C          print *,i,j
2270           do ilist=1,ishield_list(i)
2271            iresshield=shield_list(ilist,i)
2272            do k=1,3
2273            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2274      &      *2.0
2275            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2276      &              rlocshield
2277      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2278             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2279 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2280 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2281 C             if (iresshield.gt.i) then
2282 C               do ishi=i+1,iresshield-1
2283 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2284 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2285 C
2286 C              enddo
2287 C             else
2288 C               do ishi=iresshield,i
2289 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2290 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2291 C
2292 C               enddo
2293 C              endif
2294            enddo
2295           enddo
2296           do ilist=1,ishield_list(j)
2297            iresshield=shield_list(ilist,j)
2298            do k=1,3
2299            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2300      &     *2.0
2301            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2302      &              rlocshield
2303      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2304            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2305            enddo
2306           enddo
2307
2308           do k=1,3
2309             gshieldc(k,i)=gshieldc(k,i)+
2310      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2311             gshieldc(k,j)=gshieldc(k,j)+
2312      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2313             gshieldc(k,i-1)=gshieldc(k,i-1)+
2314      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2315             gshieldc(k,j-1)=gshieldc(k,j-1)+
2316      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2317
2318            enddo
2319            endif
2320
2321           do k=1,3
2322             ghalf=0.5D0*ggg(k)
2323             gelc(k,i)=gelc(k,i)+ghalf
2324             gelc(k,j)=gelc(k,j)+ghalf
2325           enddo
2326 *
2327 * Loop over residues i+1 thru j-1.
2328 *
2329           do k=i+1,j-1
2330             do l=1,3
2331               gelc(l,k)=gelc(l,k)+ggg(l)
2332             enddo
2333           enddo
2334 C          ggg(1)=facvdw*xj
2335 C          ggg(2)=facvdw*yj
2336 C          ggg(3)=facvdw*zj
2337           if (sss.gt.0.0) then
2338           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2339           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2340           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2341           else
2342           ggg(1)=0.0
2343           ggg(2)=0.0
2344           ggg(3)=0.0
2345           endif
2346           do k=1,3
2347             ghalf=0.5D0*ggg(k)
2348             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2349             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2350           enddo
2351 *
2352 * Loop over residues i+1 thru j-1.
2353 *
2354           do k=i+1,j-1
2355             do l=1,3
2356               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2357             enddo
2358           enddo
2359 #else
2360           facvdw=(ev1+evdwij)*sss
2361           facel=el1+eesij
2362           fac1=fac
2363           fac=-3*rrmij*(facvdw+facvdw+facel)
2364           erij(1)=xj*rmij
2365           erij(2)=yj*rmij
2366           erij(3)=zj*rmij
2367           if (calc_grad) then
2368 *
2369 * Radial derivatives. First process both termini of the fragment (i,j)
2370 *
2371           ggg(1)=fac*xj
2372           ggg(2)=fac*yj
2373           ggg(3)=fac*zj
2374           do k=1,3
2375             ghalf=0.5D0*ggg(k)
2376             gelc(k,i)=gelc(k,i)+ghalf
2377             gelc(k,j)=gelc(k,j)+ghalf
2378           enddo
2379 *
2380 * Loop over residues i+1 thru j-1.
2381 *
2382           do k=i+1,j-1
2383             do l=1,3
2384               gelc(l,k)=gelc(l,k)+ggg(l)
2385             enddo
2386           enddo
2387 #endif
2388 *
2389 * Angular part
2390 *
2391           ecosa=2.0D0*fac3*fac1+fac4
2392           fac4=-3.0D0*fac4
2393           fac3=-6.0D0*fac3
2394           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2395           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2396           do k=1,3
2397             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2398             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2399           enddo
2400 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2401 cd   &          (dcosg(k),k=1,3)
2402           do k=1,3
2403             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2404      &      *fac_shield(i)**2*fac_shield(j)**2
2405           enddo
2406           do k=1,3
2407             ghalf=0.5D0*ggg(k)
2408             gelc(k,i)=gelc(k,i)+ghalf
2409      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2410      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2411      &           *fac_shield(i)**2*fac_shield(j)**2
2412
2413             gelc(k,j)=gelc(k,j)+ghalf
2414      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2415      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2416      &           *fac_shield(i)**2*fac_shield(j)**2
2417           enddo
2418           do k=i+1,j-1
2419             do l=1,3
2420               gelc(l,k)=gelc(l,k)+ggg(l)
2421             enddo
2422           enddo
2423           endif
2424
2425           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2426      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2427      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2428 C
2429 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2430 C   energy of a peptide unit is assumed in the form of a second-order
2431 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2432 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2433 C   are computed for EVERY pair of non-contiguous peptide groups.
2434 C
2435           if (j.lt.nres-1) then
2436             j1=j+1
2437             j2=j-1
2438           else
2439             j1=j-1
2440             j2=j-2
2441           endif
2442           kkk=0
2443           do k=1,2
2444             do l=1,2
2445               kkk=kkk+1
2446               muij(kkk)=mu(k,i)*mu(l,j)
2447             enddo
2448           enddo
2449 cd         write (iout,*) 'EELEC: i',i,' j',j
2450 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2451 cd          write(iout,*) 'muij',muij
2452           ury=scalar(uy(1,i),erij)
2453           urz=scalar(uz(1,i),erij)
2454           vry=scalar(uy(1,j),erij)
2455           vrz=scalar(uz(1,j),erij)
2456           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2457           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2458           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2459           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2460 C For diagnostics only
2461 cd          a22=1.0d0
2462 cd          a23=1.0d0
2463 cd          a32=1.0d0
2464 cd          a33=1.0d0
2465           fac=dsqrt(-ael6i)*r3ij
2466 cd          write (2,*) 'fac=',fac
2467 C For diagnostics only
2468 cd          fac=1.0d0
2469           a22=a22*fac
2470           a23=a23*fac
2471           a32=a32*fac
2472           a33=a33*fac
2473 cd          write (iout,'(4i5,4f10.5)')
2474 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2475 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2476 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2477 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2478 cd          write (iout,'(4f10.5)')
2479 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2480 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2481 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2482 cd           write (iout,'(2i3,9f10.5/)') i,j,
2483 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2484           if (calc_grad) then
2485 C Derivatives of the elements of A in virtual-bond vectors
2486           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2487 cd          do k=1,3
2488 cd            do l=1,3
2489 cd              erder(k,l)=0.0d0
2490 cd            enddo
2491 cd          enddo
2492           do k=1,3
2493             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2494             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2495             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2496             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2497             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2498             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2499             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2500             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2501             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2502             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2503             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2504             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2505           enddo
2506 cd          do k=1,3
2507 cd            do l=1,3
2508 cd              uryg(k,l)=0.0d0
2509 cd              urzg(k,l)=0.0d0
2510 cd              vryg(k,l)=0.0d0
2511 cd              vrzg(k,l)=0.0d0
2512 cd            enddo
2513 cd          enddo
2514 C Compute radial contributions to the gradient
2515           facr=-3.0d0*rrmij
2516           a22der=a22*facr
2517           a23der=a23*facr
2518           a32der=a32*facr
2519           a33der=a33*facr
2520 cd          a22der=0.0d0
2521 cd          a23der=0.0d0
2522 cd          a32der=0.0d0
2523 cd          a33der=0.0d0
2524           agg(1,1)=a22der*xj
2525           agg(2,1)=a22der*yj
2526           agg(3,1)=a22der*zj
2527           agg(1,2)=a23der*xj
2528           agg(2,2)=a23der*yj
2529           agg(3,2)=a23der*zj
2530           agg(1,3)=a32der*xj
2531           agg(2,3)=a32der*yj
2532           agg(3,3)=a32der*zj
2533           agg(1,4)=a33der*xj
2534           agg(2,4)=a33der*yj
2535           agg(3,4)=a33der*zj
2536 C Add the contributions coming from er
2537           fac3=-3.0d0*fac
2538           do k=1,3
2539             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2540             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2541             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2542             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2543           enddo
2544           do k=1,3
2545 C Derivatives in DC(i)
2546             ghalf1=0.5d0*agg(k,1)
2547             ghalf2=0.5d0*agg(k,2)
2548             ghalf3=0.5d0*agg(k,3)
2549             ghalf4=0.5d0*agg(k,4)
2550             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2551      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2552             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2553      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2554             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2555      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2556             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2557      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2558 C Derivatives in DC(i+1)
2559             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2560      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2561             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2562      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2563             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2564      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2565             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2566      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2567 C Derivatives in DC(j)
2568             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2569      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2570             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2571      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2572             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2573      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2574             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2575      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2576 C Derivatives in DC(j+1) or DC(nres-1)
2577             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2578      &      -3.0d0*vryg(k,3)*ury)
2579             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2580      &      -3.0d0*vrzg(k,3)*ury)
2581             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2582      &      -3.0d0*vryg(k,3)*urz)
2583             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2584      &      -3.0d0*vrzg(k,3)*urz)
2585 cd            aggi(k,1)=ghalf1
2586 cd            aggi(k,2)=ghalf2
2587 cd            aggi(k,3)=ghalf3
2588 cd            aggi(k,4)=ghalf4
2589 C Derivatives in DC(i+1)
2590 cd            aggi1(k,1)=agg(k,1)
2591 cd            aggi1(k,2)=agg(k,2)
2592 cd            aggi1(k,3)=agg(k,3)
2593 cd            aggi1(k,4)=agg(k,4)
2594 C Derivatives in DC(j)
2595 cd            aggj(k,1)=ghalf1
2596 cd            aggj(k,2)=ghalf2
2597 cd            aggj(k,3)=ghalf3
2598 cd            aggj(k,4)=ghalf4
2599 C Derivatives in DC(j+1)
2600 cd            aggj1(k,1)=0.0d0
2601 cd            aggj1(k,2)=0.0d0
2602 cd            aggj1(k,3)=0.0d0
2603 cd            aggj1(k,4)=0.0d0
2604             if (j.eq.nres-1 .and. i.lt.j-2) then
2605               do l=1,4
2606                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2607 cd                aggj1(k,l)=agg(k,l)
2608               enddo
2609             endif
2610           enddo
2611           endif
2612 c          goto 11111
2613 C Check the loc-el terms by numerical integration
2614           acipa(1,1)=a22
2615           acipa(1,2)=a23
2616           acipa(2,1)=a32
2617           acipa(2,2)=a33
2618           a22=-a22
2619           a23=-a23
2620           do l=1,2
2621             do k=1,3
2622               agg(k,l)=-agg(k,l)
2623               aggi(k,l)=-aggi(k,l)
2624               aggi1(k,l)=-aggi1(k,l)
2625               aggj(k,l)=-aggj(k,l)
2626               aggj1(k,l)=-aggj1(k,l)
2627             enddo
2628           enddo
2629           if (j.lt.nres-1) then
2630             a22=-a22
2631             a32=-a32
2632             do l=1,3,2
2633               do k=1,3
2634                 agg(k,l)=-agg(k,l)
2635                 aggi(k,l)=-aggi(k,l)
2636                 aggi1(k,l)=-aggi1(k,l)
2637                 aggj(k,l)=-aggj(k,l)
2638                 aggj1(k,l)=-aggj1(k,l)
2639               enddo
2640             enddo
2641           else
2642             a22=-a22
2643             a23=-a23
2644             a32=-a32
2645             a33=-a33
2646             do l=1,4
2647               do k=1,3
2648                 agg(k,l)=-agg(k,l)
2649                 aggi(k,l)=-aggi(k,l)
2650                 aggi1(k,l)=-aggi1(k,l)
2651                 aggj(k,l)=-aggj(k,l)
2652                 aggj1(k,l)=-aggj1(k,l)
2653               enddo
2654             enddo
2655           endif
2656           ENDIF ! WCORR
2657 11111     continue
2658           IF (wel_loc.gt.0.0d0) THEN
2659 C Contribution to the local-electrostatic energy coming from the i-j pair
2660           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2661      &     +a33*muij(4)
2662           if (shield_mode.eq.0) then
2663            fac_shield(i)=1.0
2664            fac_shield(j)=1.0
2665 C          else
2666 C           fac_shield(i)=0.4
2667 C           fac_shield(j)=0.6
2668           endif
2669           eel_loc_ij=eel_loc_ij
2670      &    *fac_shield(i)*fac_shield(j)
2671 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2672 C          write (iout,'(a6,2i5,0pf7.3)')
2673 C     &            'eelloc',i,j,eel_loc_ij
2674 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2675 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2676 C          eel_loc=eel_loc+eel_loc_ij
2677           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2678      &  (shield_mode.gt.0)) then
2679 C          print *,i,j
2680
2681           do ilist=1,ishield_list(i)
2682            iresshield=shield_list(ilist,i)
2683            do k=1,3
2684            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2685      &                                          /fac_shield(i)
2686 C     &      *2.0
2687            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2688      &              rlocshield
2689      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2690             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2691      &      +rlocshield
2692            enddo
2693           enddo
2694           do ilist=1,ishield_list(j)
2695            iresshield=shield_list(ilist,j)
2696            do k=1,3
2697            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2698      &                                       /fac_shield(j)
2699 C     &     *2.0
2700            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2701      &              rlocshield
2702      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2703            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2704      &             +rlocshield
2705
2706            enddo
2707           enddo
2708           do k=1,3
2709             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2710      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2711             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2712      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2713             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2714      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2715             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2716      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2717            enddo
2718            endif
2719           eel_loc=eel_loc+eel_loc_ij
2720
2721 C Partial derivatives in virtual-bond dihedral angles gamma
2722           if (calc_grad) then
2723           if (i.gt.1)
2724      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2725      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2726      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
2727      &    *fac_shield(i)*fac_shield(j)
2728
2729           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2730      &            (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2731      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
2732      &    *fac_shield(i)*fac_shield(j)
2733
2734 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2735 cd          write(iout,*) 'agg  ',agg
2736 cd          write(iout,*) 'aggi ',aggi
2737 cd          write(iout,*) 'aggi1',aggi1
2738 cd          write(iout,*) 'aggj ',aggj
2739 cd          write(iout,*) 'aggj1',aggj1
2740
2741 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2742           do l=1,3
2743             ggg(l)=(agg(l,1)*muij(1)+
2744      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
2745      &    *fac_shield(i)*fac_shield(j)
2746
2747           enddo
2748           do k=i+2,j2
2749             do l=1,3
2750               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2751             enddo
2752           enddo
2753 C Remaining derivatives of eello
2754           do l=1,3
2755             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
2756      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
2757      &    *fac_shield(i)*fac_shield(j)
2758
2759             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
2760      &         aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
2761      &    *fac_shield(i)*fac_shield(j)
2762
2763             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
2764      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
2765      &    *fac_shield(i)*fac_shield(j)
2766
2767             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
2768      &         aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
2769      &    *fac_shield(i)*fac_shield(j)
2770
2771           enddo
2772           endif
2773           ENDIF
2774           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2775 C Contributions from turns
2776             a_temp(1,1)=a22
2777             a_temp(1,2)=a23
2778             a_temp(2,1)=a32
2779             a_temp(2,2)=a33
2780             call eturn34(i,j,eello_turn3,eello_turn4)
2781           endif
2782 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2783           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2784 C
2785 C Calculate the contact function. The ith column of the array JCONT will
2786 C contain the numbers of atoms that make contacts with the atom I (of numbers
2787 C greater than I). The arrays FACONT and GACONT will contain the values of
2788 C the contact function and its derivative.
2789 c           r0ij=1.02D0*rpp(iteli,itelj)
2790 c           r0ij=1.11D0*rpp(iteli,itelj)
2791             r0ij=2.20D0*rpp(iteli,itelj)
2792 c           r0ij=1.55D0*rpp(iteli,itelj)
2793             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2794             if (fcont.gt.0.0D0) then
2795               num_conti=num_conti+1
2796               if (num_conti.gt.maxconts) then
2797                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2798      &                         ' will skip next contacts for this conf.'
2799               else
2800                 jcont_hb(num_conti,i)=j
2801                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2802      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2803 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2804 C  terms.
2805                 d_cont(num_conti,i)=rij
2806 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2807 C     --- Electrostatic-interaction matrix ---
2808                 a_chuj(1,1,num_conti,i)=a22
2809                 a_chuj(1,2,num_conti,i)=a23
2810                 a_chuj(2,1,num_conti,i)=a32
2811                 a_chuj(2,2,num_conti,i)=a33
2812 C     --- Gradient of rij
2813                 do kkk=1,3
2814                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2815                 enddo
2816 c             if (i.eq.1) then
2817 c                a_chuj(1,1,num_conti,i)=-0.61d0
2818 c                a_chuj(1,2,num_conti,i)= 0.4d0
2819 c                a_chuj(2,1,num_conti,i)= 0.65d0
2820 c                a_chuj(2,2,num_conti,i)= 0.50d0
2821 c             else if (i.eq.2) then
2822 c                a_chuj(1,1,num_conti,i)= 0.0d0
2823 c                a_chuj(1,2,num_conti,i)= 0.0d0
2824 c                a_chuj(2,1,num_conti,i)= 0.0d0
2825 c                a_chuj(2,2,num_conti,i)= 0.0d0
2826 c             endif
2827 C     --- and its gradients
2828 cd                write (iout,*) 'i',i,' j',j
2829 cd                do kkk=1,3
2830 cd                write (iout,*) 'iii 1 kkk',kkk
2831 cd                write (iout,*) agg(kkk,:)
2832 cd                enddo
2833 cd                do kkk=1,3
2834 cd                write (iout,*) 'iii 2 kkk',kkk
2835 cd                write (iout,*) aggi(kkk,:)
2836 cd                enddo
2837 cd                do kkk=1,3
2838 cd                write (iout,*) 'iii 3 kkk',kkk
2839 cd                write (iout,*) aggi1(kkk,:)
2840 cd                enddo
2841 cd                do kkk=1,3
2842 cd                write (iout,*) 'iii 4 kkk',kkk
2843 cd                write (iout,*) aggj(kkk,:)
2844 cd                enddo
2845 cd                do kkk=1,3
2846 cd                write (iout,*) 'iii 5 kkk',kkk
2847 cd                write (iout,*) aggj1(kkk,:)
2848 cd                enddo
2849                 kkll=0
2850                 do k=1,2
2851                   do l=1,2
2852                     kkll=kkll+1
2853                     do m=1,3
2854                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2855                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2856                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2857                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2858                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2859 c                      do mm=1,5
2860 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2861 c                      enddo
2862                     enddo
2863                   enddo
2864                 enddo
2865                 ENDIF
2866                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2867 C Calculate contact energies
2868                 cosa4=4.0D0*cosa
2869                 wij=cosa-3.0D0*cosb*cosg
2870                 cosbg1=cosb+cosg
2871                 cosbg2=cosb-cosg
2872 c               fac3=dsqrt(-ael6i)/r0ij**3
2873                 fac3=dsqrt(-ael6i)*r3ij
2874                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2875                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2876 c               ees0mij=0.0D0
2877                 if (shield_mode.eq.0) then
2878                 fac_shield(i)=1.0d0
2879                 fac_shield(j)=1.0d0
2880                 else
2881                 ees0plist(num_conti,i)=j
2882 C                fac_shield(i)=0.4d0
2883 C                fac_shield(j)=0.6d0
2884                 endif
2885                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2886      &          *fac_shield(i)*fac_shield(j)
2887
2888                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2889      &          *fac_shield(i)*fac_shield(j)
2890
2891 C Diagnostics. Comment out or remove after debugging!
2892 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2893 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2894 c               ees0m(num_conti,i)=0.0D0
2895 C End diagnostics.
2896 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2897 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2898                 facont_hb(num_conti,i)=fcont
2899                 if (calc_grad) then
2900 C Angular derivatives of the contact function
2901                 ees0pij1=fac3/ees0pij
2902                 ees0mij1=fac3/ees0mij
2903                 fac3p=-3.0D0*fac3*rrmij
2904                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2905                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2906 c               ees0mij1=0.0D0
2907                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2908                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2909                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2910                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2911                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2912                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2913                 ecosap=ecosa1+ecosa2
2914                 ecosbp=ecosb1+ecosb2
2915                 ecosgp=ecosg1+ecosg2
2916                 ecosam=ecosa1-ecosa2
2917                 ecosbm=ecosb1-ecosb2
2918                 ecosgm=ecosg1-ecosg2
2919 C Diagnostics
2920 c               ecosap=ecosa1
2921 c               ecosbp=ecosb1
2922 c               ecosgp=ecosg1
2923 c               ecosam=0.0D0
2924 c               ecosbm=0.0D0
2925 c               ecosgm=0.0D0
2926 C End diagnostics
2927                 fprimcont=fprimcont/rij
2928 cd              facont_hb(num_conti,i)=1.0D0
2929 C Following line is for diagnostics.
2930 cd              fprimcont=0.0D0
2931                 do k=1,3
2932                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2933                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2934                 enddo
2935                 do k=1,3
2936                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2937                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2938                 enddo
2939                 gggp(1)=gggp(1)+ees0pijp*xj
2940                 gggp(2)=gggp(2)+ees0pijp*yj
2941                 gggp(3)=gggp(3)+ees0pijp*zj
2942                 gggm(1)=gggm(1)+ees0mijp*xj
2943                 gggm(2)=gggm(2)+ees0mijp*yj
2944                 gggm(3)=gggm(3)+ees0mijp*zj
2945 C Derivatives due to the contact function
2946                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2947                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2948                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2949                 do k=1,3
2950                   ghalfp=0.5D0*gggp(k)
2951                   ghalfm=0.5D0*gggm(k)
2952                   gacontp_hb1(k,num_conti,i)=ghalfp
2953      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2954      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2955      &          *fac_shield(i)*fac_shield(j)
2956
2957                   gacontp_hb2(k,num_conti,i)=ghalfp
2958      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2959      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2960      &          *fac_shield(i)*fac_shield(j)
2961
2962                   gacontp_hb3(k,num_conti,i)=gggp(k)
2963                   gacontm_hb1(k,num_conti,i)=ghalfm
2964      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2965      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2966      &          *fac_shield(i)*fac_shield(j)
2967
2968                   gacontm_hb2(k,num_conti,i)=ghalfm
2969      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2970      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2971      &          *fac_shield(i)*fac_shield(j)
2972
2973                   gacontm_hb3(k,num_conti,i)=gggm(k)
2974      &          *fac_shield(i)*fac_shield(j)
2975
2976                 enddo
2977                 endif
2978 C Diagnostics. Comment out or remove after debugging!
2979 cdiag           do k=1,3
2980 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2981 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2982 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2983 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2984 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2985 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2986 cdiag           enddo
2987               ENDIF ! wcorr
2988               endif  ! num_conti.le.maxconts
2989             endif  ! fcont.gt.0
2990           endif    ! j.gt.i+1
2991  1216     continue
2992         enddo ! j
2993         num_cont_hb(i)=num_conti
2994  1215   continue
2995       enddo   ! i
2996 cd      do i=1,nres
2997 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2998 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2999 cd      enddo
3000 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3001 ccc      eel_loc=eel_loc+eello_turn3
3002       return
3003       end
3004 C-----------------------------------------------------------------------------
3005       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3006 C Third- and fourth-order contributions from turns
3007       implicit real*8 (a-h,o-z)
3008       include 'DIMENSIONS'
3009       include 'DIMENSIONS.ZSCOPT'
3010       include 'COMMON.IOUNITS'
3011       include 'COMMON.GEO'
3012       include 'COMMON.VAR'
3013       include 'COMMON.LOCAL'
3014       include 'COMMON.CHAIN'
3015       include 'COMMON.DERIV'
3016       include 'COMMON.INTERACT'
3017       include 'COMMON.CONTACTS'
3018       include 'COMMON.TORSION'
3019       include 'COMMON.VECTORS'
3020       include 'COMMON.FFIELD'
3021       include 'COMMON.SHIELD'
3022       include 'COMMON.CONTROL'
3023       dimension ggg(3)
3024       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3025      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3026      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3027       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3028      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3029       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3030       if (j.eq.i+2) then
3031 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3032 C
3033 C               Third-order contributions
3034 C
3035 C                 (i+2)o----(i+3)
3036 C                      | |
3037 C                      | |
3038 C                 (i+1)o----i
3039 C
3040 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3041 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3042         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3043         call transpose2(auxmat(1,1),auxmat1(1,1))
3044         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3045         if (shield_mode.eq.0) then
3046         fac_shield(i)=1.0
3047         fac_shield(j)=1.0
3048 C        else
3049 C        fac_shield(i)=0.4
3050 C        fac_shield(j)=0.6
3051         endif
3052
3053         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3054      &  *fac_shield(i)*fac_shield(j)
3055         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3056      &  *fac_shield(i)*fac_shield(j)
3057
3058 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3059 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3060 cd     &    ' eello_turn3_num',4*eello_turn3_num
3061         if (calc_grad) then
3062 C Derivatives in shield mode
3063           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3064      &  (shield_mode.gt.0)) then
3065 C          print *,i,j
3066
3067           do ilist=1,ishield_list(i)
3068            iresshield=shield_list(ilist,i)
3069            do k=1,3
3070            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3071 C     &      *2.0
3072            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3073      &              rlocshield
3074      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3075             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3076      &      +rlocshield
3077            enddo
3078           enddo
3079           do ilist=1,ishield_list(j)
3080            iresshield=shield_list(ilist,j)
3081            do k=1,3
3082            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3083 C     &     *2.0
3084            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3085      &              rlocshield
3086      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3087            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3088      &             +rlocshield
3089
3090            enddo
3091           enddo
3092
3093           do k=1,3
3094             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3095      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3096             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3097      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3098             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3099      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3100             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3101      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3102            enddo
3103            endif
3104
3105 C Derivatives in gamma(i)
3106         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3107         call transpose2(auxmat2(1,1),pizda(1,1))
3108         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3109         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3110 C Derivatives in gamma(i+1)
3111         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3112         call transpose2(auxmat2(1,1),pizda(1,1))
3113         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3114         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3115      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3116      &   *fac_shield(i)*fac_shield(j)
3117
3118 C Cartesian derivatives
3119         do l=1,3
3120           a_temp(1,1)=aggi(l,1)
3121           a_temp(1,2)=aggi(l,2)
3122           a_temp(2,1)=aggi(l,3)
3123           a_temp(2,2)=aggi(l,4)
3124           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3125           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3126      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3127      &   *fac_shield(i)*fac_shield(j)
3128
3129           a_temp(1,1)=aggi1(l,1)
3130           a_temp(1,2)=aggi1(l,2)
3131           a_temp(2,1)=aggi1(l,3)
3132           a_temp(2,2)=aggi1(l,4)
3133           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3134           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3135      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3136      &   *fac_shield(i)*fac_shield(j)
3137
3138           a_temp(1,1)=aggj(l,1)
3139           a_temp(1,2)=aggj(l,2)
3140           a_temp(2,1)=aggj(l,3)
3141           a_temp(2,2)=aggj(l,4)
3142           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3143           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3144      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3145      &   *fac_shield(i)*fac_shield(j)
3146
3147           a_temp(1,1)=aggj1(l,1)
3148           a_temp(1,2)=aggj1(l,2)
3149           a_temp(2,1)=aggj1(l,3)
3150           a_temp(2,2)=aggj1(l,4)
3151           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3152           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3153      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3154      &   *fac_shield(i)*fac_shield(j)
3155
3156         enddo
3157         endif
3158       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3159       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3160 C changes suggested by Ana to avoid out of bounds
3161      & .or.((i+5).gt.nres)
3162      & .or.((i-1).le.0)
3163 C end of changes suggested by Ana
3164      &    .or. itype(i+3).eq.ntyp1
3165      &    .or. itype(i+4).eq.ntyp1
3166      &    .or. itype(i+5).eq.ntyp1
3167      &    .or. itype(i).eq.ntyp1
3168      &    .or. itype(i-1).eq.ntyp1) goto 178
3169 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3170 C
3171 C               Fourth-order contributions
3172 C
3173 C                 (i+3)o----(i+4)
3174 C                     /  |
3175 C               (i+2)o   |
3176 C                     \  |
3177 C                 (i+1)o----i
3178 C
3179 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3180 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3181         iti1=itortyp(itype(i+1))
3182         iti2=itortyp(itype(i+2))
3183         iti3=itortyp(itype(i+3))
3184         call transpose2(EUg(1,1,i+1),e1t(1,1))
3185         call transpose2(Eug(1,1,i+2),e2t(1,1))
3186         call transpose2(Eug(1,1,i+3),e3t(1,1))
3187         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3188         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3189         s1=scalar2(b1(1,iti2),auxvec(1))
3190         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3191         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3192         s2=scalar2(b1(1,iti1),auxvec(1))
3193         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3194         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3195         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3196         if (shield_mode.eq.0) then
3197         fac_shield(i)=1.0
3198         fac_shield(j)=1.0
3199 C        else
3200 C        fac_shield(i)=0.4
3201 C        fac_shield(j)=0.6
3202         endif
3203
3204         eello_turn4=eello_turn4-(s1+s2+s3)
3205      &  *fac_shield(i)*fac_shield(j)
3206         eello_t4=-(s1+s2+s3)
3207      &  *fac_shield(i)*fac_shield(j)
3208
3209 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3210 cd     &    ' eello_turn4_num',8*eello_turn4_num
3211 C Derivatives in gamma(i)
3212         if (calc_grad) then
3213           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3214      &  (shield_mode.gt.0)) then
3215 C          print *,i,j
3216
3217           do ilist=1,ishield_list(i)
3218            iresshield=shield_list(ilist,i)
3219            do k=1,3
3220            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3221 C     &      *2.0
3222            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3223      &              rlocshield
3224      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3225             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3226      &      +rlocshield
3227            enddo
3228           enddo
3229           do ilist=1,ishield_list(j)
3230            iresshield=shield_list(ilist,j)
3231            do k=1,3
3232            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3233 C     &     *2.0
3234            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3235      &              rlocshield
3236      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3237            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3238      &             +rlocshield
3239
3240            enddo
3241           enddo
3242
3243           do k=1,3
3244             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3245      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3246             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3247      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3248             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3249      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3250             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3251      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3252            enddo
3253            endif
3254         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3255         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3256         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3257         s1=scalar2(b1(1,iti2),auxvec(1))
3258         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3259         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3260         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3261      &  *fac_shield(i)*fac_shield(j)
3262
3263 C Derivatives in gamma(i+1)
3264         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3265         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3266         s2=scalar2(b1(1,iti1),auxvec(1))
3267         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3268         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3269         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3270         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3271      &  *fac_shield(i)*fac_shield(j)
3272
3273 C Derivatives in gamma(i+2)
3274         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3275         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3276         s1=scalar2(b1(1,iti2),auxvec(1))
3277         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3278         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3279         s2=scalar2(b1(1,iti1),auxvec(1))
3280         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3281         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3282         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3283         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3284      &  *fac_shield(i)*fac_shield(j)
3285
3286 C Cartesian derivatives
3287
3288 C Derivatives of this turn contributions in DC(i+2)
3289         if (j.lt.nres-1) then
3290           do l=1,3
3291             a_temp(1,1)=agg(l,1)
3292             a_temp(1,2)=agg(l,2)
3293             a_temp(2,1)=agg(l,3)
3294             a_temp(2,2)=agg(l,4)
3295             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3296             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3297             s1=scalar2(b1(1,iti2),auxvec(1))
3298             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3299             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3300             s2=scalar2(b1(1,iti1),auxvec(1))
3301             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3302             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3303             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3304             ggg(l)=-(s1+s2+s3)
3305             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3306      &  *fac_shield(i)*fac_shield(j)
3307
3308           enddo
3309         endif
3310 C Remaining derivatives of this turn contribution
3311         do l=1,3
3312           a_temp(1,1)=aggi(l,1)
3313           a_temp(1,2)=aggi(l,2)
3314           a_temp(2,1)=aggi(l,3)
3315           a_temp(2,2)=aggi(l,4)
3316           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3317           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3318           s1=scalar2(b1(1,iti2),auxvec(1))
3319           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3320           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3321           s2=scalar2(b1(1,iti1),auxvec(1))
3322           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3323           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3324           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3325           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3326      &  *fac_shield(i)*fac_shield(j)
3327
3328           a_temp(1,1)=aggi1(l,1)
3329           a_temp(1,2)=aggi1(l,2)
3330           a_temp(2,1)=aggi1(l,3)
3331           a_temp(2,2)=aggi1(l,4)
3332           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3333           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3334           s1=scalar2(b1(1,iti2),auxvec(1))
3335           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3336           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3337           s2=scalar2(b1(1,iti1),auxvec(1))
3338           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3339           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3340           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3341           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3342      &  *fac_shield(i)*fac_shield(j)
3343
3344           a_temp(1,1)=aggj(l,1)
3345           a_temp(1,2)=aggj(l,2)
3346           a_temp(2,1)=aggj(l,3)
3347           a_temp(2,2)=aggj(l,4)
3348           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3349           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3350           s1=scalar2(b1(1,iti2),auxvec(1))
3351           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3352           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3353           s2=scalar2(b1(1,iti1),auxvec(1))
3354           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3355           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3356           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3357           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3358      &  *fac_shield(i)*fac_shield(j)
3359
3360           a_temp(1,1)=aggj1(l,1)
3361           a_temp(1,2)=aggj1(l,2)
3362           a_temp(2,1)=aggj1(l,3)
3363           a_temp(2,2)=aggj1(l,4)
3364           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3365           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3366           s1=scalar2(b1(1,iti2),auxvec(1))
3367           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3368           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3369           s2=scalar2(b1(1,iti1),auxvec(1))
3370           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3371           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3372           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3373           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3374      &  *fac_shield(i)*fac_shield(j)
3375
3376         enddo
3377         endif
3378  178  continue
3379       endif
3380       return
3381       end
3382 C-----------------------------------------------------------------------------
3383       subroutine vecpr(u,v,w)
3384       implicit real*8(a-h,o-z)
3385       dimension u(3),v(3),w(3)
3386       w(1)=u(2)*v(3)-u(3)*v(2)
3387       w(2)=-u(1)*v(3)+u(3)*v(1)
3388       w(3)=u(1)*v(2)-u(2)*v(1)
3389       return
3390       end
3391 C-----------------------------------------------------------------------------
3392       subroutine unormderiv(u,ugrad,unorm,ungrad)
3393 C This subroutine computes the derivatives of a normalized vector u, given
3394 C the derivatives computed without normalization conditions, ugrad. Returns
3395 C ungrad.
3396       implicit none
3397       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3398       double precision vec(3)
3399       double precision scalar
3400       integer i,j
3401 c      write (2,*) 'ugrad',ugrad
3402 c      write (2,*) 'u',u
3403       do i=1,3
3404         vec(i)=scalar(ugrad(1,i),u(1))
3405       enddo
3406 c      write (2,*) 'vec',vec
3407       do i=1,3
3408         do j=1,3
3409           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3410         enddo
3411       enddo
3412 c      write (2,*) 'ungrad',ungrad
3413       return
3414       end
3415 C-----------------------------------------------------------------------------
3416       subroutine escp(evdw2,evdw2_14)
3417 C
3418 C This subroutine calculates the excluded-volume interaction energy between
3419 C peptide-group centers and side chains and its gradient in virtual-bond and
3420 C side-chain vectors.
3421 C
3422       implicit real*8 (a-h,o-z)
3423       include 'DIMENSIONS'
3424       include 'DIMENSIONS.ZSCOPT'
3425       include 'COMMON.GEO'
3426       include 'COMMON.VAR'
3427       include 'COMMON.LOCAL'
3428       include 'COMMON.CHAIN'
3429       include 'COMMON.DERIV'
3430       include 'COMMON.INTERACT'
3431       include 'COMMON.FFIELD'
3432       include 'COMMON.IOUNITS'
3433       dimension ggg(3)
3434       evdw2=0.0D0
3435       evdw2_14=0.0d0
3436 cd    print '(a)','Enter ESCP'
3437 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3438 c     &  ' scal14',scal14
3439       do i=iatscp_s,iatscp_e
3440         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3441         iteli=itel(i)
3442 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3443 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3444         if (iteli.eq.0) goto 1225
3445         xi=0.5D0*(c(1,i)+c(1,i+1))
3446         yi=0.5D0*(c(2,i)+c(2,i+1))
3447         zi=0.5D0*(c(3,i)+c(3,i+1))
3448 C Returning the ith atom to box
3449           xi=mod(xi,boxxsize)
3450           if (xi.lt.0) xi=xi+boxxsize
3451           yi=mod(yi,boxysize)
3452           if (yi.lt.0) yi=yi+boxysize
3453           zi=mod(zi,boxzsize)
3454           if (zi.lt.0) zi=zi+boxzsize
3455         do iint=1,nscp_gr(i)
3456
3457         do j=iscpstart(i,iint),iscpend(i,iint)
3458           itypj=iabs(itype(j))
3459           if (itypj.eq.ntyp1) cycle
3460 C Uncomment following three lines for SC-p interactions
3461 c         xj=c(1,nres+j)-xi
3462 c         yj=c(2,nres+j)-yi
3463 c         zj=c(3,nres+j)-zi
3464 C Uncomment following three lines for Ca-p interactions
3465           xj=c(1,j)
3466           yj=c(2,j)
3467           zj=c(3,j)
3468 C returning the jth atom to box
3469           xj=mod(xj,boxxsize)
3470           if (xj.lt.0) xj=xj+boxxsize
3471           yj=mod(yj,boxysize)
3472           if (yj.lt.0) yj=yj+boxysize
3473           zj=mod(zj,boxzsize)
3474           if (zj.lt.0) zj=zj+boxzsize
3475       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3476       xj_safe=xj
3477       yj_safe=yj
3478       zj_safe=zj
3479       subchap=0
3480 C Finding the closest jth atom
3481       do xshift=-1,1
3482       do yshift=-1,1
3483       do zshift=-1,1
3484           xj=xj_safe+xshift*boxxsize
3485           yj=yj_safe+yshift*boxysize
3486           zj=zj_safe+zshift*boxzsize
3487           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3488           if(dist_temp.lt.dist_init) then
3489             dist_init=dist_temp
3490             xj_temp=xj
3491             yj_temp=yj
3492             zj_temp=zj
3493             subchap=1
3494           endif
3495        enddo
3496        enddo
3497        enddo
3498        if (subchap.eq.1) then
3499           xj=xj_temp-xi
3500           yj=yj_temp-yi
3501           zj=zj_temp-zi
3502        else
3503           xj=xj_safe-xi
3504           yj=yj_safe-yi
3505           zj=zj_safe-zi
3506        endif
3507           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3508 C sss is scaling function for smoothing the cutoff gradient otherwise
3509 C the gradient would not be continuouse
3510           sss=sscale(1.0d0/(dsqrt(rrij)))
3511           if (sss.le.0.0d0) cycle
3512           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3513           fac=rrij**expon2
3514           e1=fac*fac*aad(itypj,iteli)
3515           e2=fac*bad(itypj,iteli)
3516           if (iabs(j-i) .le. 2) then
3517             e1=scal14*e1
3518             e2=scal14*e2
3519             evdw2_14=evdw2_14+(e1+e2)*sss
3520           endif
3521           evdwij=e1+e2
3522 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3523 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3524 c     &       bad(itypj,iteli)
3525           evdw2=evdw2+evdwij*sss
3526           if (calc_grad) then
3527 C
3528 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3529 C
3530           fac=-(evdwij+e1)*rrij*sss
3531           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3532           ggg(1)=xj*fac
3533           ggg(2)=yj*fac
3534           ggg(3)=zj*fac
3535           if (j.lt.i) then
3536 cd          write (iout,*) 'j<i'
3537 C Uncomment following three lines for SC-p interactions
3538 c           do k=1,3
3539 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3540 c           enddo
3541           else
3542 cd          write (iout,*) 'j>i'
3543             do k=1,3
3544               ggg(k)=-ggg(k)
3545 C Uncomment following line for SC-p interactions
3546 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3547             enddo
3548           endif
3549           do k=1,3
3550             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3551           enddo
3552           kstart=min0(i+1,j)
3553           kend=max0(i-1,j-1)
3554 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3555 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3556           do k=kstart,kend
3557             do l=1,3
3558               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3559             enddo
3560           enddo
3561           endif
3562         enddo
3563         enddo ! iint
3564  1225   continue
3565       enddo ! i
3566       do i=1,nct
3567         do j=1,3
3568           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3569           gradx_scp(j,i)=expon*gradx_scp(j,i)
3570         enddo
3571       enddo
3572 C******************************************************************************
3573 C
3574 C                              N O T E !!!
3575 C
3576 C To save time the factor EXPON has been extracted from ALL components
3577 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3578 C use!
3579 C
3580 C******************************************************************************
3581       return
3582       end
3583 C--------------------------------------------------------------------------
3584       subroutine edis(ehpb)
3585 C
3586 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3587 C
3588       implicit real*8 (a-h,o-z)
3589       include 'DIMENSIONS'
3590       include 'DIMENSIONS.ZSCOPT'
3591       include 'COMMON.SBRIDGE'
3592       include 'COMMON.CHAIN'
3593       include 'COMMON.DERIV'
3594       include 'COMMON.VAR'
3595       include 'COMMON.INTERACT'
3596       include 'COMMON.CONTROL'
3597       include 'COMMON.IOUNITS'
3598       dimension ggg(3)
3599       ehpb=0.0D0
3600 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3601 cd    print *,'link_start=',link_start,' link_end=',link_end
3602 C      write(iout,*) link_end, "link_end"
3603       if (link_end.eq.0) return
3604       do i=link_start,link_end
3605 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3606 C CA-CA distance used in regularization of structure.
3607         ii=ihpb(i)
3608         jj=jhpb(i)
3609 C iii and jjj point to the residues for which the distance is assigned.
3610         if (ii.gt.nres) then
3611           iii=ii-nres
3612           jjj=jj-nres
3613         else
3614           iii=ii
3615           jjj=jj
3616         endif
3617 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3618 C    distance and angle dependent SS bond potential.
3619 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3620 C     & iabs(itype(jjj)).eq.1) then
3621 C       write(iout,*) constr_dist,"const"
3622        if (.not.dyn_ss .and. i.le.nss) then
3623          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3624      & iabs(itype(jjj)).eq.1) then
3625           call ssbond_ene(iii,jjj,eij)
3626           ehpb=ehpb+2*eij
3627            endif !ii.gt.neres
3628         else if (ii.gt.nres .and. jj.gt.nres) then
3629 c Restraints from contact prediction
3630           dd=dist(ii,jj)
3631           if (constr_dist.eq.11) then
3632 C            ehpb=ehpb+fordepth(i)**4.0d0
3633 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3634             ehpb=ehpb+fordepth(i)**4.0d0
3635      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3636             fac=fordepth(i)**4.0d0
3637      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3638 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3639 C     &    ehpb,fordepth(i),dd
3640 C            write(iout,*) ehpb,"atu?"
3641 C            ehpb,"tu?"
3642 C            fac=fordepth(i)**4.0d0
3643 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3644            else
3645           if (dhpb1(i).gt.0.0d0) then
3646             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3647             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3648 c            write (iout,*) "beta nmr",
3649 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3650           else
3651             dd=dist(ii,jj)
3652             rdis=dd-dhpb(i)
3653 C Get the force constant corresponding to this distance.
3654             waga=forcon(i)
3655 C Calculate the contribution to energy.
3656             ehpb=ehpb+waga*rdis*rdis
3657 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3658 C
3659 C Evaluate gradient.
3660 C
3661             fac=waga*rdis/dd
3662           endif !end dhpb1(i).gt.0
3663           endif !end const_dist=11
3664           do j=1,3
3665             ggg(j)=fac*(c(j,jj)-c(j,ii))
3666           enddo
3667           do j=1,3
3668             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3669             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3670           enddo
3671           do k=1,3
3672             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3673             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3674           enddo
3675         else !ii.gt.nres
3676 C          write(iout,*) "before"
3677           dd=dist(ii,jj)
3678 C          write(iout,*) "after",dd
3679           if (constr_dist.eq.11) then
3680             ehpb=ehpb+fordepth(i)**4.0d0
3681      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3682             fac=fordepth(i)**4.0d0
3683      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3684 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3685 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3686 C            print *,ehpb,"tu?"
3687 C            write(iout,*) ehpb,"btu?",
3688 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3689 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3690 C     &    ehpb,fordepth(i),dd
3691            else
3692           if (dhpb1(i).gt.0.0d0) then
3693             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3694             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3695 c            write (iout,*) "alph nmr",
3696 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3697           else
3698             rdis=dd-dhpb(i)
3699 C Get the force constant corresponding to this distance.
3700             waga=forcon(i)
3701 C Calculate the contribution to energy.
3702             ehpb=ehpb+waga*rdis*rdis
3703 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3704 C
3705 C Evaluate gradient.
3706 C
3707             fac=waga*rdis/dd
3708           endif
3709           endif
3710
3711         do j=1,3
3712           ggg(j)=fac*(c(j,jj)-c(j,ii))
3713         enddo
3714 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3715 C If this is a SC-SC distance, we need to calculate the contributions to the
3716 C Cartesian gradient in the SC vectors (ghpbx).
3717         if (iii.lt.ii) then
3718           do j=1,3
3719             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3720             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3721           enddo
3722         endif
3723         do j=iii,jjj-1
3724           do k=1,3
3725             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3726           enddo
3727         enddo
3728         endif
3729       enddo
3730       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3731       return
3732       end
3733 C--------------------------------------------------------------------------
3734       subroutine ssbond_ene(i,j,eij)
3735 C
3736 C Calculate the distance and angle dependent SS-bond potential energy
3737 C using a free-energy function derived based on RHF/6-31G** ab initio
3738 C calculations of diethyl disulfide.
3739 C
3740 C A. Liwo and U. Kozlowska, 11/24/03
3741 C
3742       implicit real*8 (a-h,o-z)
3743       include 'DIMENSIONS'
3744       include 'DIMENSIONS.ZSCOPT'
3745       include 'COMMON.SBRIDGE'
3746       include 'COMMON.CHAIN'
3747       include 'COMMON.DERIV'
3748       include 'COMMON.LOCAL'
3749       include 'COMMON.INTERACT'
3750       include 'COMMON.VAR'
3751       include 'COMMON.IOUNITS'
3752       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3753       itypi=iabs(itype(i))
3754       xi=c(1,nres+i)
3755       yi=c(2,nres+i)
3756       zi=c(3,nres+i)
3757       dxi=dc_norm(1,nres+i)
3758       dyi=dc_norm(2,nres+i)
3759       dzi=dc_norm(3,nres+i)
3760       dsci_inv=dsc_inv(itypi)
3761       itypj=iabs(itype(j))
3762       dscj_inv=dsc_inv(itypj)
3763       xj=c(1,nres+j)-xi
3764       yj=c(2,nres+j)-yi
3765       zj=c(3,nres+j)-zi
3766       dxj=dc_norm(1,nres+j)
3767       dyj=dc_norm(2,nres+j)
3768       dzj=dc_norm(3,nres+j)
3769       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3770       rij=dsqrt(rrij)
3771       erij(1)=xj*rij
3772       erij(2)=yj*rij
3773       erij(3)=zj*rij
3774       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3775       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3776       om12=dxi*dxj+dyi*dyj+dzi*dzj
3777       do k=1,3
3778         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3779         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3780       enddo
3781       rij=1.0d0/rij
3782       deltad=rij-d0cm
3783       deltat1=1.0d0-om1
3784       deltat2=1.0d0+om2
3785       deltat12=om2-om1+2.0d0
3786       cosphi=om12-om1*om2
3787       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3788      &  +akct*deltad*deltat12
3789      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3790 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3791 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3792 c     &  " deltat12",deltat12," eij",eij
3793       ed=2*akcm*deltad+akct*deltat12
3794       pom1=akct*deltad
3795       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3796       eom1=-2*akth*deltat1-pom1-om2*pom2
3797       eom2= 2*akth*deltat2+pom1-om1*pom2
3798       eom12=pom2
3799       do k=1,3
3800         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3801       enddo
3802       do k=1,3
3803         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3804      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3805         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3806      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3807       enddo
3808 C
3809 C Calculate the components of the gradient in DC and X
3810 C
3811       do k=i,j-1
3812         do l=1,3
3813           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3814         enddo
3815       enddo
3816       return
3817       end
3818 C--------------------------------------------------------------------------
3819       subroutine ebond(estr)
3820 c
3821 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3822 c
3823       implicit real*8 (a-h,o-z)
3824       include 'DIMENSIONS'
3825       include 'DIMENSIONS.ZSCOPT'
3826       include 'COMMON.LOCAL'
3827       include 'COMMON.GEO'
3828       include 'COMMON.INTERACT'
3829       include 'COMMON.DERIV'
3830       include 'COMMON.VAR'
3831       include 'COMMON.CHAIN'
3832       include 'COMMON.IOUNITS'
3833       include 'COMMON.NAMES'
3834       include 'COMMON.FFIELD'
3835       include 'COMMON.CONTROL'
3836       logical energy_dec /.false./
3837       double precision u(3),ud(3)
3838       estr=0.0d0
3839       estr1=0.0d0
3840 c      write (iout,*) "distchainmax",distchainmax
3841       do i=nnt+1,nct
3842         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3843 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3844 C          do j=1,3
3845 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3846 C     &      *dc(j,i-1)/vbld(i)
3847 C          enddo
3848 C          if (energy_dec) write(iout,*)
3849 C     &       "estr1",i,vbld(i),distchainmax,
3850 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3851 C        else
3852          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3853         diff = vbld(i)-vbldpDUM
3854          else
3855           diff = vbld(i)-vbldp0
3856 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3857          endif
3858           estr=estr+diff*diff
3859           do j=1,3
3860             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3861           enddo
3862 C        endif
3863 C        write (iout,'(a7,i5,4f7.3)')
3864 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3865       enddo
3866       estr=0.5d0*AKP*estr+estr1
3867 c
3868 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3869 c
3870       do i=nnt,nct
3871         iti=iabs(itype(i))
3872         if (iti.ne.10 .and. iti.ne.ntyp1) then
3873           nbi=nbondterm(iti)
3874           if (nbi.eq.1) then
3875             diff=vbld(i+nres)-vbldsc0(1,iti)
3876 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3877 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3878             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3879             do j=1,3
3880               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3881             enddo
3882           else
3883             do j=1,nbi
3884               diff=vbld(i+nres)-vbldsc0(j,iti)
3885               ud(j)=aksc(j,iti)*diff
3886               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3887             enddo
3888             uprod=u(1)
3889             do j=2,nbi
3890               uprod=uprod*u(j)
3891             enddo
3892             usum=0.0d0
3893             usumsqder=0.0d0
3894             do j=1,nbi
3895               uprod1=1.0d0
3896               uprod2=1.0d0
3897               do k=1,nbi
3898                 if (k.ne.j) then
3899                   uprod1=uprod1*u(k)
3900                   uprod2=uprod2*u(k)*u(k)
3901                 endif
3902               enddo
3903               usum=usum+uprod1
3904               usumsqder=usumsqder+ud(j)*uprod2
3905             enddo
3906 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3907 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3908             estr=estr+uprod/usum
3909             do j=1,3
3910              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3911             enddo
3912           endif
3913         endif
3914       enddo
3915       return
3916       end
3917 #ifdef CRYST_THETA
3918 C--------------------------------------------------------------------------
3919       subroutine ebend(etheta,ethetacnstr)
3920 C
3921 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3922 C angles gamma and its derivatives in consecutive thetas and gammas.
3923 C
3924       implicit real*8 (a-h,o-z)
3925       include 'DIMENSIONS'
3926       include 'DIMENSIONS.ZSCOPT'
3927       include 'COMMON.LOCAL'
3928       include 'COMMON.GEO'
3929       include 'COMMON.INTERACT'
3930       include 'COMMON.DERIV'
3931       include 'COMMON.VAR'
3932       include 'COMMON.CHAIN'
3933       include 'COMMON.IOUNITS'
3934       include 'COMMON.NAMES'
3935       include 'COMMON.FFIELD'
3936       include 'COMMON.TORCNSTR'
3937       common /calcthet/ term1,term2,termm,diffak,ratak,
3938      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3939      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3940       double precision y(2),z(2)
3941       delta=0.02d0*pi
3942 c      time11=dexp(-2*time)
3943 c      time12=1.0d0
3944       etheta=0.0D0
3945 c      write (iout,*) "nres",nres
3946 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3947 c      write (iout,*) ithet_start,ithet_end
3948       do i=ithet_start,ithet_end
3949 C        if (itype(i-1).eq.ntyp1) cycle
3950         if (i.le.2) cycle
3951         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3952      &  .or.itype(i).eq.ntyp1) cycle
3953 C Zero the energy function and its derivative at 0 or pi.
3954         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3955         it=itype(i-1)
3956         ichir1=isign(1,itype(i-2))
3957         ichir2=isign(1,itype(i))
3958          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
3959          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
3960          if (itype(i-1).eq.10) then
3961           itype1=isign(10,itype(i-2))
3962           ichir11=isign(1,itype(i-2))
3963           ichir12=isign(1,itype(i-2))
3964           itype2=isign(10,itype(i))
3965           ichir21=isign(1,itype(i))
3966           ichir22=isign(1,itype(i))
3967          endif
3968          if (i.eq.3) then
3969           y(1)=0.0D0
3970           y(2)=0.0D0
3971           else
3972
3973         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3974 #ifdef OSF
3975           phii=phi(i)
3976 c          icrc=0
3977 c          call proc_proc(phii,icrc)
3978           if (icrc.eq.1) phii=150.0
3979 #else
3980           phii=phi(i)
3981 #endif
3982           y(1)=dcos(phii)
3983           y(2)=dsin(phii)
3984         else
3985           y(1)=0.0D0
3986           y(2)=0.0D0
3987         endif
3988         endif
3989         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3990 #ifdef OSF
3991           phii1=phi(i+1)
3992 c          icrc=0
3993 c          call proc_proc(phii1,icrc)
3994           if (icrc.eq.1) phii1=150.0
3995           phii1=pinorm(phii1)
3996           z(1)=cos(phii1)
3997 #else
3998           phii1=phi(i+1)
3999           z(1)=dcos(phii1)
4000 #endif
4001           z(2)=dsin(phii1)
4002         else
4003           z(1)=0.0D0
4004           z(2)=0.0D0
4005         endif
4006 C Calculate the "mean" value of theta from the part of the distribution
4007 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4008 C In following comments this theta will be referred to as t_c.
4009         thet_pred_mean=0.0d0
4010         do k=1,2
4011             athetk=athet(k,it,ichir1,ichir2)
4012             bthetk=bthet(k,it,ichir1,ichir2)
4013           if (it.eq.10) then
4014              athetk=athet(k,itype1,ichir11,ichir12)
4015              bthetk=bthet(k,itype2,ichir21,ichir22)
4016           endif
4017           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4018         enddo
4019 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4020         dthett=thet_pred_mean*ssd
4021         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4022 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4023 C Derivatives of the "mean" values in gamma1 and gamma2.
4024         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4025      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4026          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4027      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4028          if (it.eq.10) then
4029       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4030      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4031         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4032      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4033          endif
4034         if (theta(i).gt.pi-delta) then
4035           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4036      &         E_tc0)
4037           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4038           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4039           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4040      &        E_theta)
4041           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4042      &        E_tc)
4043         else if (theta(i).lt.delta) then
4044           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4045           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4046           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4047      &        E_theta)
4048           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4049           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4050      &        E_tc)
4051         else
4052           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4053      &        E_theta,E_tc)
4054         endif
4055         etheta=etheta+ethetai
4056 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4057 c     &      'ebend',i,ethetai,theta(i),itype(i)
4058 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4059 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4060         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4061         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4062         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4063 c 1215   continue
4064       enddo
4065       ethetacnstr=0.0d0
4066 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4067       do i=1,ntheta_constr
4068         itheta=itheta_constr(i)
4069         thetiii=theta(itheta)
4070         difi=pinorm(thetiii-theta_constr0(i))
4071         if (difi.gt.theta_drange(i)) then
4072           difi=difi-theta_drange(i)
4073           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4074           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4075      &    +for_thet_constr(i)*difi**3
4076         else if (difi.lt.-drange(i)) then
4077           difi=difi+drange(i)
4078           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4079           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4080      &    +for_thet_constr(i)*difi**3
4081         else
4082           difi=0.0
4083         endif
4084 C       if (energy_dec) then
4085 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4086 C     &    i,itheta,rad2deg*thetiii,
4087 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4088 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4089 C     &    gloc(itheta+nphi-2,icg)
4090 C        endif
4091       enddo
4092 C Ufff.... We've done all this!!!
4093       return
4094       end
4095 C---------------------------------------------------------------------------
4096       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4097      &     E_tc)
4098       implicit real*8 (a-h,o-z)
4099       include 'DIMENSIONS'
4100       include 'COMMON.LOCAL'
4101       include 'COMMON.IOUNITS'
4102       common /calcthet/ term1,term2,termm,diffak,ratak,
4103      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4104      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4105 C Calculate the contributions to both Gaussian lobes.
4106 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4107 C The "polynomial part" of the "standard deviation" of this part of
4108 C the distribution.
4109         sig=polthet(3,it)
4110         do j=2,0,-1
4111           sig=sig*thet_pred_mean+polthet(j,it)
4112         enddo
4113 C Derivative of the "interior part" of the "standard deviation of the"
4114 C gamma-dependent Gaussian lobe in t_c.
4115         sigtc=3*polthet(3,it)
4116         do j=2,1,-1
4117           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4118         enddo
4119         sigtc=sig*sigtc
4120 C Set the parameters of both Gaussian lobes of the distribution.
4121 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4122         fac=sig*sig+sigc0(it)
4123         sigcsq=fac+fac
4124         sigc=1.0D0/sigcsq
4125 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4126         sigsqtc=-4.0D0*sigcsq*sigtc
4127 c       print *,i,sig,sigtc,sigsqtc
4128 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4129         sigtc=-sigtc/(fac*fac)
4130 C Following variable is sigma(t_c)**(-2)
4131         sigcsq=sigcsq*sigcsq
4132         sig0i=sig0(it)
4133         sig0inv=1.0D0/sig0i**2
4134         delthec=thetai-thet_pred_mean
4135         delthe0=thetai-theta0i
4136         term1=-0.5D0*sigcsq*delthec*delthec
4137         term2=-0.5D0*sig0inv*delthe0*delthe0
4138 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4139 C NaNs in taking the logarithm. We extract the largest exponent which is added
4140 C to the energy (this being the log of the distribution) at the end of energy
4141 C term evaluation for this virtual-bond angle.
4142         if (term1.gt.term2) then
4143           termm=term1
4144           term2=dexp(term2-termm)
4145           term1=1.0d0
4146         else
4147           termm=term2
4148           term1=dexp(term1-termm)
4149           term2=1.0d0
4150         endif
4151 C The ratio between the gamma-independent and gamma-dependent lobes of
4152 C the distribution is a Gaussian function of thet_pred_mean too.
4153         diffak=gthet(2,it)-thet_pred_mean
4154         ratak=diffak/gthet(3,it)**2
4155         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4156 C Let's differentiate it in thet_pred_mean NOW.
4157         aktc=ak*ratak
4158 C Now put together the distribution terms to make complete distribution.
4159         termexp=term1+ak*term2
4160         termpre=sigc+ak*sig0i
4161 C Contribution of the bending energy from this theta is just the -log of
4162 C the sum of the contributions from the two lobes and the pre-exponential
4163 C factor. Simple enough, isn't it?
4164         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4165 C NOW the derivatives!!!
4166 C 6/6/97 Take into account the deformation.
4167         E_theta=(delthec*sigcsq*term1
4168      &       +ak*delthe0*sig0inv*term2)/termexp
4169         E_tc=((sigtc+aktc*sig0i)/termpre
4170      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4171      &       aktc*term2)/termexp)
4172       return
4173       end
4174 c-----------------------------------------------------------------------------
4175       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4176       implicit real*8 (a-h,o-z)
4177       include 'DIMENSIONS'
4178       include 'COMMON.LOCAL'
4179       include 'COMMON.IOUNITS'
4180       common /calcthet/ term1,term2,termm,diffak,ratak,
4181      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4182      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4183       delthec=thetai-thet_pred_mean
4184       delthe0=thetai-theta0i
4185 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4186       t3 = thetai-thet_pred_mean
4187       t6 = t3**2
4188       t9 = term1
4189       t12 = t3*sigcsq
4190       t14 = t12+t6*sigsqtc
4191       t16 = 1.0d0
4192       t21 = thetai-theta0i
4193       t23 = t21**2
4194       t26 = term2
4195       t27 = t21*t26
4196       t32 = termexp
4197       t40 = t32**2
4198       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4199      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4200      & *(-t12*t9-ak*sig0inv*t27)
4201       return
4202       end
4203 #else
4204 C--------------------------------------------------------------------------
4205       subroutine ebend(etheta,ethetacnstr)
4206 C
4207 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4208 C angles gamma and its derivatives in consecutive thetas and gammas.
4209 C ab initio-derived potentials from
4210 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4211 C
4212       implicit real*8 (a-h,o-z)
4213       include 'DIMENSIONS'
4214       include 'DIMENSIONS.ZSCOPT'
4215       include 'COMMON.LOCAL'
4216       include 'COMMON.GEO'
4217       include 'COMMON.INTERACT'
4218       include 'COMMON.DERIV'
4219       include 'COMMON.VAR'
4220       include 'COMMON.CHAIN'
4221       include 'COMMON.IOUNITS'
4222       include 'COMMON.NAMES'
4223       include 'COMMON.FFIELD'
4224       include 'COMMON.CONTROL'
4225       include 'COMMON.TORCNSTR'
4226       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4227      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4228      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4229      & sinph1ph2(maxdouble,maxdouble)
4230       logical lprn /.false./, lprn1 /.false./
4231       etheta=0.0D0
4232 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4233       do i=ithet_start,ithet_end
4234 C         if (i.eq.2) cycle
4235 C        if (itype(i-1).eq.ntyp1) cycle
4236         if (i.le.2) cycle
4237         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4238      &  .or.itype(i).eq.ntyp1) cycle
4239         if (iabs(itype(i+1)).eq.20) iblock=2
4240         if (iabs(itype(i+1)).ne.20) iblock=1
4241         dethetai=0.0d0
4242         dephii=0.0d0
4243         dephii1=0.0d0
4244         theti2=0.5d0*theta(i)
4245         ityp2=ithetyp((itype(i-1)))
4246         do k=1,nntheterm
4247           coskt(k)=dcos(k*theti2)
4248           sinkt(k)=dsin(k*theti2)
4249         enddo
4250         if (i.eq.3) then
4251           phii=0.0d0
4252           ityp1=nthetyp+1
4253           do k=1,nsingle
4254             cosph1(k)=0.0d0
4255             sinph1(k)=0.0d0
4256           enddo
4257         else
4258         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4259 #ifdef OSF
4260           phii=phi(i)
4261           if (phii.ne.phii) phii=150.0
4262 #else
4263           phii=phi(i)
4264 #endif
4265           ityp1=ithetyp((itype(i-2)))
4266           do k=1,nsingle
4267             cosph1(k)=dcos(k*phii)
4268             sinph1(k)=dsin(k*phii)
4269           enddo
4270         else
4271           phii=0.0d0
4272 c          ityp1=nthetyp+1
4273           do k=1,nsingle
4274             ityp1=ithetyp((itype(i-2)))
4275             cosph1(k)=0.0d0
4276             sinph1(k)=0.0d0
4277           enddo
4278         endif
4279         endif
4280         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4281 #ifdef OSF
4282           phii1=phi(i+1)
4283           if (phii1.ne.phii1) phii1=150.0
4284           phii1=pinorm(phii1)
4285 #else
4286           phii1=phi(i+1)
4287 #endif
4288           ityp3=ithetyp((itype(i)))
4289           do k=1,nsingle
4290             cosph2(k)=dcos(k*phii1)
4291             sinph2(k)=dsin(k*phii1)
4292           enddo
4293         else
4294           phii1=0.0d0
4295 c          ityp3=nthetyp+1
4296           ityp3=ithetyp((itype(i)))
4297           do k=1,nsingle
4298             cosph2(k)=0.0d0
4299             sinph2(k)=0.0d0
4300           enddo
4301         endif
4302 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4303 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4304 c        call flush(iout)
4305         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4306         do k=1,ndouble
4307           do l=1,k-1
4308             ccl=cosph1(l)*cosph2(k-l)
4309             ssl=sinph1(l)*sinph2(k-l)
4310             scl=sinph1(l)*cosph2(k-l)
4311             csl=cosph1(l)*sinph2(k-l)
4312             cosph1ph2(l,k)=ccl-ssl
4313             cosph1ph2(k,l)=ccl+ssl
4314             sinph1ph2(l,k)=scl+csl
4315             sinph1ph2(k,l)=scl-csl
4316           enddo
4317         enddo
4318         if (lprn) then
4319         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4320      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4321         write (iout,*) "coskt and sinkt"
4322         do k=1,nntheterm
4323           write (iout,*) k,coskt(k),sinkt(k)
4324         enddo
4325         endif
4326         do k=1,ntheterm
4327           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4328           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4329      &      *coskt(k)
4330           if (lprn)
4331      &    write (iout,*) "k",k,"
4332      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4333      &     " ethetai",ethetai
4334         enddo
4335         if (lprn) then
4336         write (iout,*) "cosph and sinph"
4337         do k=1,nsingle
4338           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4339         enddo
4340         write (iout,*) "cosph1ph2 and sinph2ph2"
4341         do k=2,ndouble
4342           do l=1,k-1
4343             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4344      &         sinph1ph2(l,k),sinph1ph2(k,l)
4345           enddo
4346         enddo
4347         write(iout,*) "ethetai",ethetai
4348         endif
4349         do m=1,ntheterm2
4350           do k=1,nsingle
4351             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4352      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4353      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4354      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4355             ethetai=ethetai+sinkt(m)*aux
4356             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4357             dephii=dephii+k*sinkt(m)*(
4358      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4359      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4360             dephii1=dephii1+k*sinkt(m)*(
4361      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4362      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4363             if (lprn)
4364      &      write (iout,*) "m",m," k",k," bbthet",
4365      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4366      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4367      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4368      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4369           enddo
4370         enddo
4371         if (lprn)
4372      &  write(iout,*) "ethetai",ethetai
4373         do m=1,ntheterm3
4374           do k=2,ndouble
4375             do l=1,k-1
4376               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4377      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4378      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4379      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4380               ethetai=ethetai+sinkt(m)*aux
4381               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4382               dephii=dephii+l*sinkt(m)*(
4383      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4384      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4385      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4386      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4387               dephii1=dephii1+(k-l)*sinkt(m)*(
4388      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4389      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4390      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4391      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4392               if (lprn) then
4393               write (iout,*) "m",m," k",k," l",l," ffthet",
4394      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4395      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4396      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4397      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4398      &            " ethetai",ethetai
4399               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4400      &            cosph1ph2(k,l)*sinkt(m),
4401      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4402               endif
4403             enddo
4404           enddo
4405         enddo
4406 10      continue
4407         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4408      &   i,theta(i)*rad2deg,phii*rad2deg,
4409      &   phii1*rad2deg,ethetai
4410         etheta=etheta+ethetai
4411         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4412         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4413 c        gloc(nphi+i-2,icg)=wang*dethetai
4414         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4415       enddo
4416 C now constrains
4417       ethetacnstr=0.0d0
4418 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4419       do i=1,ntheta_constr
4420         itheta=itheta_constr(i)
4421         thetiii=theta(itheta)
4422         difi=pinorm(thetiii-theta_constr0(i))
4423         if (difi.gt.theta_drange(i)) then
4424           difi=difi-theta_drange(i)
4425           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4426           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4427      &    +for_thet_constr(i)*difi**3
4428         else if (difi.lt.-drange(i)) then
4429           difi=difi+drange(i)
4430           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4431           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4432      &    +for_thet_constr(i)*difi**3
4433         else
4434           difi=0.0
4435         endif
4436 C       if (energy_dec) then
4437 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4438 C     &    i,itheta,rad2deg*thetiii,
4439 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4440 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4441 C     &    gloc(itheta+nphi-2,icg)
4442 C        endif
4443       enddo
4444       return
4445       end
4446 #endif
4447 #ifdef CRYST_SC
4448 c-----------------------------------------------------------------------------
4449       subroutine esc(escloc)
4450 C Calculate the local energy of a side chain and its derivatives in the
4451 C corresponding virtual-bond valence angles THETA and the spherical angles
4452 C ALPHA and OMEGA.
4453       implicit real*8 (a-h,o-z)
4454       include 'DIMENSIONS'
4455       include 'DIMENSIONS.ZSCOPT'
4456       include 'COMMON.GEO'
4457       include 'COMMON.LOCAL'
4458       include 'COMMON.VAR'
4459       include 'COMMON.INTERACT'
4460       include 'COMMON.DERIV'
4461       include 'COMMON.CHAIN'
4462       include 'COMMON.IOUNITS'
4463       include 'COMMON.NAMES'
4464       include 'COMMON.FFIELD'
4465       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4466      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4467       common /sccalc/ time11,time12,time112,theti,it,nlobit
4468       delta=0.02d0*pi
4469       escloc=0.0D0
4470 C      write (iout,*) 'ESC'
4471       do i=loc_start,loc_end
4472         it=itype(i)
4473         if (it.eq.ntyp1) cycle
4474         if (it.eq.10) goto 1
4475         nlobit=nlob(iabs(it))
4476 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4477 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4478         theti=theta(i+1)-pipol
4479         x(1)=dtan(theti)
4480         x(2)=alph(i)
4481         x(3)=omeg(i)
4482 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4483
4484         if (x(2).gt.pi-delta) then
4485           xtemp(1)=x(1)
4486           xtemp(2)=pi-delta
4487           xtemp(3)=x(3)
4488           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4489           xtemp(2)=pi
4490           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4491           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4492      &        escloci,dersc(2))
4493           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4494      &        ddersc0(1),dersc(1))
4495           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4496      &        ddersc0(3),dersc(3))
4497           xtemp(2)=pi-delta
4498           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4499           xtemp(2)=pi
4500           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4501           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4502      &            dersc0(2),esclocbi,dersc02)
4503           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4504      &            dersc12,dersc01)
4505           call splinthet(x(2),0.5d0*delta,ss,ssd)
4506           dersc0(1)=dersc01
4507           dersc0(2)=dersc02
4508           dersc0(3)=0.0d0
4509           do k=1,3
4510             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4511           enddo
4512           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4513           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4514      &             esclocbi,ss,ssd
4515           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4516 c         escloci=esclocbi
4517 c         write (iout,*) escloci
4518         else if (x(2).lt.delta) then
4519           xtemp(1)=x(1)
4520           xtemp(2)=delta
4521           xtemp(3)=x(3)
4522           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4523           xtemp(2)=0.0d0
4524           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4525           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4526      &        escloci,dersc(2))
4527           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4528      &        ddersc0(1),dersc(1))
4529           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4530      &        ddersc0(3),dersc(3))
4531           xtemp(2)=delta
4532           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4533           xtemp(2)=0.0d0
4534           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4535           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4536      &            dersc0(2),esclocbi,dersc02)
4537           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4538      &            dersc12,dersc01)
4539           dersc0(1)=dersc01
4540           dersc0(2)=dersc02
4541           dersc0(3)=0.0d0
4542           call splinthet(x(2),0.5d0*delta,ss,ssd)
4543           do k=1,3
4544             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4545           enddo
4546           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4547 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4548 c     &             esclocbi,ss,ssd
4549           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4550 C         write (iout,*) 'i=',i, escloci
4551         else
4552           call enesc(x,escloci,dersc,ddummy,.false.)
4553         endif
4554
4555         escloc=escloc+escloci
4556 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4557             write (iout,'(a6,i5,0pf7.3)')
4558      &     'escloc',i,escloci
4559
4560         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4561      &   wscloc*dersc(1)
4562         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4563         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4564     1   continue
4565       enddo
4566       return
4567       end
4568 C---------------------------------------------------------------------------
4569       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4570       implicit real*8 (a-h,o-z)
4571       include 'DIMENSIONS'
4572       include 'COMMON.GEO'
4573       include 'COMMON.LOCAL'
4574       include 'COMMON.IOUNITS'
4575       common /sccalc/ time11,time12,time112,theti,it,nlobit
4576       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4577       double precision contr(maxlob,-1:1)
4578       logical mixed
4579 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4580         escloc_i=0.0D0
4581         do j=1,3
4582           dersc(j)=0.0D0
4583           if (mixed) ddersc(j)=0.0d0
4584         enddo
4585         x3=x(3)
4586
4587 C Because of periodicity of the dependence of the SC energy in omega we have
4588 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4589 C To avoid underflows, first compute & store the exponents.
4590
4591         do iii=-1,1
4592
4593           x(3)=x3+iii*dwapi
4594
4595           do j=1,nlobit
4596             do k=1,3
4597               z(k)=x(k)-censc(k,j,it)
4598             enddo
4599             do k=1,3
4600               Axk=0.0D0
4601               do l=1,3
4602                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4603               enddo
4604               Ax(k,j,iii)=Axk
4605             enddo
4606             expfac=0.0D0
4607             do k=1,3
4608               expfac=expfac+Ax(k,j,iii)*z(k)
4609             enddo
4610             contr(j,iii)=expfac
4611           enddo ! j
4612
4613         enddo ! iii
4614
4615         x(3)=x3
4616 C As in the case of ebend, we want to avoid underflows in exponentiation and
4617 C subsequent NaNs and INFs in energy calculation.
4618 C Find the largest exponent
4619         emin=contr(1,-1)
4620         do iii=-1,1
4621           do j=1,nlobit
4622             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4623           enddo
4624         enddo
4625         emin=0.5D0*emin
4626 cd      print *,'it=',it,' emin=',emin
4627
4628 C Compute the contribution to SC energy and derivatives
4629         do iii=-1,1
4630
4631           do j=1,nlobit
4632             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4633 cd          print *,'j=',j,' expfac=',expfac
4634             escloc_i=escloc_i+expfac
4635             do k=1,3
4636               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4637             enddo
4638             if (mixed) then
4639               do k=1,3,2
4640                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4641      &            +gaussc(k,2,j,it))*expfac
4642               enddo
4643             endif
4644           enddo
4645
4646         enddo ! iii
4647
4648         dersc(1)=dersc(1)/cos(theti)**2
4649         ddersc(1)=ddersc(1)/cos(theti)**2
4650         ddersc(3)=ddersc(3)
4651
4652         escloci=-(dlog(escloc_i)-emin)
4653         do j=1,3
4654           dersc(j)=dersc(j)/escloc_i
4655         enddo
4656         if (mixed) then
4657           do j=1,3,2
4658             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4659           enddo
4660         endif
4661       return
4662       end
4663 C------------------------------------------------------------------------------
4664       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4665       implicit real*8 (a-h,o-z)
4666       include 'DIMENSIONS'
4667       include 'COMMON.GEO'
4668       include 'COMMON.LOCAL'
4669       include 'COMMON.IOUNITS'
4670       common /sccalc/ time11,time12,time112,theti,it,nlobit
4671       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4672       double precision contr(maxlob)
4673       logical mixed
4674
4675       escloc_i=0.0D0
4676
4677       do j=1,3
4678         dersc(j)=0.0D0
4679       enddo
4680
4681       do j=1,nlobit
4682         do k=1,2
4683           z(k)=x(k)-censc(k,j,it)
4684         enddo
4685         z(3)=dwapi
4686         do k=1,3
4687           Axk=0.0D0
4688           do l=1,3
4689             Axk=Axk+gaussc(l,k,j,it)*z(l)
4690           enddo
4691           Ax(k,j)=Axk
4692         enddo
4693         expfac=0.0D0
4694         do k=1,3
4695           expfac=expfac+Ax(k,j)*z(k)
4696         enddo
4697         contr(j)=expfac
4698       enddo ! j
4699
4700 C As in the case of ebend, we want to avoid underflows in exponentiation and
4701 C subsequent NaNs and INFs in energy calculation.
4702 C Find the largest exponent
4703       emin=contr(1)
4704       do j=1,nlobit
4705         if (emin.gt.contr(j)) emin=contr(j)
4706       enddo
4707       emin=0.5D0*emin
4708
4709 C Compute the contribution to SC energy and derivatives
4710
4711       dersc12=0.0d0
4712       do j=1,nlobit
4713         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4714         escloc_i=escloc_i+expfac
4715         do k=1,2
4716           dersc(k)=dersc(k)+Ax(k,j)*expfac
4717         enddo
4718         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4719      &            +gaussc(1,2,j,it))*expfac
4720         dersc(3)=0.0d0
4721       enddo
4722
4723       dersc(1)=dersc(1)/cos(theti)**2
4724       dersc12=dersc12/cos(theti)**2
4725       escloci=-(dlog(escloc_i)-emin)
4726       do j=1,2
4727         dersc(j)=dersc(j)/escloc_i
4728       enddo
4729       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4730       return
4731       end
4732 #else
4733 c----------------------------------------------------------------------------------
4734       subroutine esc(escloc)
4735 C Calculate the local energy of a side chain and its derivatives in the
4736 C corresponding virtual-bond valence angles THETA and the spherical angles
4737 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4738 C added by Urszula Kozlowska. 07/11/2007
4739 C
4740       implicit real*8 (a-h,o-z)
4741       include 'DIMENSIONS'
4742       include 'DIMENSIONS.ZSCOPT'
4743       include 'COMMON.GEO'
4744       include 'COMMON.LOCAL'
4745       include 'COMMON.VAR'
4746       include 'COMMON.SCROT'
4747       include 'COMMON.INTERACT'
4748       include 'COMMON.DERIV'
4749       include 'COMMON.CHAIN'
4750       include 'COMMON.IOUNITS'
4751       include 'COMMON.NAMES'
4752       include 'COMMON.FFIELD'
4753       include 'COMMON.CONTROL'
4754       include 'COMMON.VECTORS'
4755       double precision x_prime(3),y_prime(3),z_prime(3)
4756      &    , sumene,dsc_i,dp2_i,x(65),
4757      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4758      &    de_dxx,de_dyy,de_dzz,de_dt
4759       double precision s1_t,s1_6_t,s2_t,s2_6_t
4760       double precision
4761      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4762      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4763      & dt_dCi(3),dt_dCi1(3)
4764       common /sccalc/ time11,time12,time112,theti,it,nlobit
4765       delta=0.02d0*pi
4766       escloc=0.0D0
4767       do i=loc_start,loc_end
4768         if (itype(i).eq.ntyp1) cycle
4769         costtab(i+1) =dcos(theta(i+1))
4770         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4771         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4772         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4773         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4774         cosfac=dsqrt(cosfac2)
4775         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4776         sinfac=dsqrt(sinfac2)
4777         it=iabs(itype(i))
4778         if (it.eq.10) goto 1
4779 c
4780 C  Compute the axes of tghe local cartesian coordinates system; store in
4781 c   x_prime, y_prime and z_prime
4782 c
4783         do j=1,3
4784           x_prime(j) = 0.00
4785           y_prime(j) = 0.00
4786           z_prime(j) = 0.00
4787         enddo
4788 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4789 C     &   dc_norm(3,i+nres)
4790         do j = 1,3
4791           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4792           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4793         enddo
4794         do j = 1,3
4795           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4796         enddo
4797 c       write (2,*) "i",i
4798 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4799 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4800 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4801 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4802 c      & " xy",scalar(x_prime(1),y_prime(1)),
4803 c      & " xz",scalar(x_prime(1),z_prime(1)),
4804 c      & " yy",scalar(y_prime(1),y_prime(1)),
4805 c      & " yz",scalar(y_prime(1),z_prime(1)),
4806 c      & " zz",scalar(z_prime(1),z_prime(1))
4807 c
4808 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4809 C to local coordinate system. Store in xx, yy, zz.
4810 c
4811         xx=0.0d0
4812         yy=0.0d0
4813         zz=0.0d0
4814         do j = 1,3
4815           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4816           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4817           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4818         enddo
4819
4820         xxtab(i)=xx
4821         yytab(i)=yy
4822         zztab(i)=zz
4823 C
4824 C Compute the energy of the ith side cbain
4825 C
4826 c        write (2,*) "xx",xx," yy",yy," zz",zz
4827         it=iabs(itype(i))
4828         do j = 1,65
4829           x(j) = sc_parmin(j,it)
4830         enddo
4831 #ifdef CHECK_COORD
4832 Cc diagnostics - remove later
4833         xx1 = dcos(alph(2))
4834         yy1 = dsin(alph(2))*dcos(omeg(2))
4835         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4836         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4837      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4838      &    xx1,yy1,zz1
4839 C,"  --- ", xx_w,yy_w,zz_w
4840 c end diagnostics
4841 #endif
4842         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4843      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4844      &   + x(10)*yy*zz
4845         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4846      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4847      & + x(20)*yy*zz
4848         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4849      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4850      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4851      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4852      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4853      &  +x(40)*xx*yy*zz
4854         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4855      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4856      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4857      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4858      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4859      &  +x(60)*xx*yy*zz
4860         dsc_i   = 0.743d0+x(61)
4861         dp2_i   = 1.9d0+x(62)
4862         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4863      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4864         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4865      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4866         s1=(1+x(63))/(0.1d0 + dscp1)
4867         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4868         s2=(1+x(65))/(0.1d0 + dscp2)
4869         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4870         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4871      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4872 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4873 c     &   sumene4,
4874 c     &   dscp1,dscp2,sumene
4875 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4876         escloc = escloc + sumene
4877 c        write (2,*) "escloc",escloc
4878 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
4879 c     &  zz,xx,yy
4880         if (.not. calc_grad) goto 1
4881 #ifdef DEBUG
4882 C
4883 C This section to check the numerical derivatives of the energy of ith side
4884 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4885 C #define DEBUG in the code to turn it on.
4886 C
4887         write (2,*) "sumene               =",sumene
4888         aincr=1.0d-7
4889         xxsave=xx
4890         xx=xx+aincr
4891         write (2,*) xx,yy,zz
4892         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4893         de_dxx_num=(sumenep-sumene)/aincr
4894         xx=xxsave
4895         write (2,*) "xx+ sumene from enesc=",sumenep
4896         yysave=yy
4897         yy=yy+aincr
4898         write (2,*) xx,yy,zz
4899         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4900         de_dyy_num=(sumenep-sumene)/aincr
4901         yy=yysave
4902         write (2,*) "yy+ sumene from enesc=",sumenep
4903         zzsave=zz
4904         zz=zz+aincr
4905         write (2,*) xx,yy,zz
4906         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4907         de_dzz_num=(sumenep-sumene)/aincr
4908         zz=zzsave
4909         write (2,*) "zz+ sumene from enesc=",sumenep
4910         costsave=cost2tab(i+1)
4911         sintsave=sint2tab(i+1)
4912         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4913         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4914         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4915         de_dt_num=(sumenep-sumene)/aincr
4916         write (2,*) " t+ sumene from enesc=",sumenep
4917         cost2tab(i+1)=costsave
4918         sint2tab(i+1)=sintsave
4919 C End of diagnostics section.
4920 #endif
4921 C
4922 C Compute the gradient of esc
4923 C
4924         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4925         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4926         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4927         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4928         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4929         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4930         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4931         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4932         pom1=(sumene3*sint2tab(i+1)+sumene1)
4933      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4934         pom2=(sumene4*cost2tab(i+1)+sumene2)
4935      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4936         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4937         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4938      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4939      &  +x(40)*yy*zz
4940         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4941         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4942      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4943      &  +x(60)*yy*zz
4944         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4945      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4946      &        +(pom1+pom2)*pom_dx
4947 #ifdef DEBUG
4948         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4949 #endif
4950 C
4951         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4952         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4953      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4954      &  +x(40)*xx*zz
4955         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4956         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4957      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4958      &  +x(59)*zz**2 +x(60)*xx*zz
4959         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4960      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4961      &        +(pom1-pom2)*pom_dy
4962 #ifdef DEBUG
4963         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4964 #endif
4965 C
4966         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4967      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4968      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4969      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4970      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4971      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4972      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4973      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4974 #ifdef DEBUG
4975         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4976 #endif
4977 C
4978         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4979      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4980      &  +pom1*pom_dt1+pom2*pom_dt2
4981 #ifdef DEBUG
4982         write(2,*), "de_dt = ", de_dt,de_dt_num
4983 #endif
4984 c
4985 C
4986        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4987        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4988        cosfac2xx=cosfac2*xx
4989        sinfac2yy=sinfac2*yy
4990        do k = 1,3
4991          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4992      &      vbld_inv(i+1)
4993          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4994      &      vbld_inv(i)
4995          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4996          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4997 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4998 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4999 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5000 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5001          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5002          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5003          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5004          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5005          dZZ_Ci1(k)=0.0d0
5006          dZZ_Ci(k)=0.0d0
5007          do j=1,3
5008            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5009      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5010            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5011      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5012          enddo
5013
5014          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5015          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5016          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5017 c
5018          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5019          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5020        enddo
5021
5022        do k=1,3
5023          dXX_Ctab(k,i)=dXX_Ci(k)
5024          dXX_C1tab(k,i)=dXX_Ci1(k)
5025          dYY_Ctab(k,i)=dYY_Ci(k)
5026          dYY_C1tab(k,i)=dYY_Ci1(k)
5027          dZZ_Ctab(k,i)=dZZ_Ci(k)
5028          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5029          dXX_XYZtab(k,i)=dXX_XYZ(k)
5030          dYY_XYZtab(k,i)=dYY_XYZ(k)
5031          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5032        enddo
5033
5034        do k = 1,3
5035 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5036 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5037 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5038 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5039 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5040 c     &    dt_dci(k)
5041 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5042 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5043          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5044      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5045          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5046      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5047          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5048      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5049        enddo
5050 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5051 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5052
5053 C to check gradient call subroutine check_grad
5054
5055     1 continue
5056       enddo
5057       return
5058       end
5059 #endif
5060 c------------------------------------------------------------------------------
5061       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5062 C
5063 C This procedure calculates two-body contact function g(rij) and its derivative:
5064 C
5065 C           eps0ij                                     !       x < -1
5066 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5067 C            0                                         !       x > 1
5068 C
5069 C where x=(rij-r0ij)/delta
5070 C
5071 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5072 C
5073       implicit none
5074       double precision rij,r0ij,eps0ij,fcont,fprimcont
5075       double precision x,x2,x4,delta
5076 c     delta=0.02D0*r0ij
5077 c      delta=0.2D0*r0ij
5078       x=(rij-r0ij)/delta
5079       if (x.lt.-1.0D0) then
5080         fcont=eps0ij
5081         fprimcont=0.0D0
5082       else if (x.le.1.0D0) then
5083         x2=x*x
5084         x4=x2*x2
5085         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5086         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5087       else
5088         fcont=0.0D0
5089         fprimcont=0.0D0
5090       endif
5091       return
5092       end
5093 c------------------------------------------------------------------------------
5094       subroutine splinthet(theti,delta,ss,ssder)
5095       implicit real*8 (a-h,o-z)
5096       include 'DIMENSIONS'
5097       include 'DIMENSIONS.ZSCOPT'
5098       include 'COMMON.VAR'
5099       include 'COMMON.GEO'
5100       thetup=pi-delta
5101       thetlow=delta
5102       if (theti.gt.pipol) then
5103         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5104       else
5105         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5106         ssder=-ssder
5107       endif
5108       return
5109       end
5110 c------------------------------------------------------------------------------
5111       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5112       implicit none
5113       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5114       double precision ksi,ksi2,ksi3,a1,a2,a3
5115       a1=fprim0*delta/(f1-f0)
5116       a2=3.0d0-2.0d0*a1
5117       a3=a1-2.0d0
5118       ksi=(x-x0)/delta
5119       ksi2=ksi*ksi
5120       ksi3=ksi2*ksi
5121       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5122       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5123       return
5124       end
5125 c------------------------------------------------------------------------------
5126       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5127       implicit none
5128       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5129       double precision ksi,ksi2,ksi3,a1,a2,a3
5130       ksi=(x-x0)/delta
5131       ksi2=ksi*ksi
5132       ksi3=ksi2*ksi
5133       a1=fprim0x*delta
5134       a2=3*(f1x-f0x)-2*fprim0x*delta
5135       a3=fprim0x*delta-2*(f1x-f0x)
5136       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5137       return
5138       end
5139 C-----------------------------------------------------------------------------
5140 #ifdef CRYST_TOR
5141 C-----------------------------------------------------------------------------
5142       subroutine etor(etors,edihcnstr,fact)
5143       implicit real*8 (a-h,o-z)
5144       include 'DIMENSIONS'
5145       include 'DIMENSIONS.ZSCOPT'
5146       include 'COMMON.VAR'
5147       include 'COMMON.GEO'
5148       include 'COMMON.LOCAL'
5149       include 'COMMON.TORSION'
5150       include 'COMMON.INTERACT'
5151       include 'COMMON.DERIV'
5152       include 'COMMON.CHAIN'
5153       include 'COMMON.NAMES'
5154       include 'COMMON.IOUNITS'
5155       include 'COMMON.FFIELD'
5156       include 'COMMON.TORCNSTR'
5157       logical lprn
5158 C Set lprn=.true. for debugging
5159       lprn=.false.
5160 c      lprn=.true.
5161       etors=0.0D0
5162       do i=iphi_start,iphi_end
5163         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5164      &      .or. itype(i).eq.ntyp1) cycle
5165         itori=itortyp(itype(i-2))
5166         itori1=itortyp(itype(i-1))
5167         phii=phi(i)
5168         gloci=0.0D0
5169 C Proline-Proline pair is a special case...
5170         if (itori.eq.3 .and. itori1.eq.3) then
5171           if (phii.gt.-dwapi3) then
5172             cosphi=dcos(3*phii)
5173             fac=1.0D0/(1.0D0-cosphi)
5174             etorsi=v1(1,3,3)*fac
5175             etorsi=etorsi+etorsi
5176             etors=etors+etorsi-v1(1,3,3)
5177             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5178           endif
5179           do j=1,3
5180             v1ij=v1(j+1,itori,itori1)
5181             v2ij=v2(j+1,itori,itori1)
5182             cosphi=dcos(j*phii)
5183             sinphi=dsin(j*phii)
5184             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5185             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5186           enddo
5187         else
5188           do j=1,nterm_old
5189             v1ij=v1(j,itori,itori1)
5190             v2ij=v2(j,itori,itori1)
5191             cosphi=dcos(j*phii)
5192             sinphi=dsin(j*phii)
5193             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5194             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5195           enddo
5196         endif
5197         if (lprn)
5198      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5199      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5200      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5201         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5202 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5203       enddo
5204 ! 6/20/98 - dihedral angle constraints
5205       edihcnstr=0.0d0
5206       do i=1,ndih_constr
5207         itori=idih_constr(i)
5208         phii=phi(itori)
5209         difi=phii-phi0(i)
5210         if (difi.gt.drange(i)) then
5211           difi=difi-drange(i)
5212           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5213           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5214         else if (difi.lt.-drange(i)) then
5215           difi=difi+drange(i)
5216           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5217           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5218         endif
5219 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5220 C     &    i,itori,rad2deg*phii,
5221 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5222       enddo
5223 !      write (iout,*) 'edihcnstr',edihcnstr
5224       return
5225       end
5226 c------------------------------------------------------------------------------
5227 #else
5228       subroutine etor(etors,edihcnstr,fact)
5229       implicit real*8 (a-h,o-z)
5230       include 'DIMENSIONS'
5231       include 'DIMENSIONS.ZSCOPT'
5232       include 'COMMON.VAR'
5233       include 'COMMON.GEO'
5234       include 'COMMON.LOCAL'
5235       include 'COMMON.TORSION'
5236       include 'COMMON.INTERACT'
5237       include 'COMMON.DERIV'
5238       include 'COMMON.CHAIN'
5239       include 'COMMON.NAMES'
5240       include 'COMMON.IOUNITS'
5241       include 'COMMON.FFIELD'
5242       include 'COMMON.TORCNSTR'
5243       logical lprn
5244 C Set lprn=.true. for debugging
5245       lprn=.false.
5246 c      lprn=.true.
5247       etors=0.0D0
5248       do i=iphi_start,iphi_end
5249         if (i.le.2) cycle
5250         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5251      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5252 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5253 C     &       .or. itype(i).eq.ntyp1) cycle
5254         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5255          if (iabs(itype(i)).eq.20) then
5256          iblock=2
5257          else
5258          iblock=1
5259          endif
5260         itori=itortyp(itype(i-2))
5261         itori1=itortyp(itype(i-1))
5262         phii=phi(i)
5263         gloci=0.0D0
5264 C Regular cosine and sine terms
5265         do j=1,nterm(itori,itori1,iblock)
5266           v1ij=v1(j,itori,itori1,iblock)
5267           v2ij=v2(j,itori,itori1,iblock)
5268           cosphi=dcos(j*phii)
5269           sinphi=dsin(j*phii)
5270           etors=etors+v1ij*cosphi+v2ij*sinphi
5271           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5272         enddo
5273 C Lorentz terms
5274 C                         v1
5275 C  E = SUM ----------------------------------- - v1
5276 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5277 C
5278         cosphi=dcos(0.5d0*phii)
5279         sinphi=dsin(0.5d0*phii)
5280         do j=1,nlor(itori,itori1,iblock)
5281           vl1ij=vlor1(j,itori,itori1)
5282           vl2ij=vlor2(j,itori,itori1)
5283           vl3ij=vlor3(j,itori,itori1)
5284           pom=vl2ij*cosphi+vl3ij*sinphi
5285           pom1=1.0d0/(pom*pom+1.0d0)
5286           etors=etors+vl1ij*pom1
5287 c          if (energy_dec) etors_ii=etors_ii+
5288 c     &                vl1ij*pom1
5289           pom=-pom*pom1*pom1
5290           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5291         enddo
5292 C Subtract the constant term
5293         etors=etors-v0(itori,itori1,iblock)
5294         if (lprn)
5295      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5296      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5297      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5298         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5299 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5300  1215   continue
5301       enddo
5302 ! 6/20/98 - dihedral angle constraints
5303       edihcnstr=0.0d0
5304       do i=1,ndih_constr
5305         itori=idih_constr(i)
5306         phii=phi(itori)
5307         difi=pinorm(phii-phi0(i))
5308         edihi=0.0d0
5309         if (difi.gt.drange(i)) then
5310           difi=difi-drange(i)
5311           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5312           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5313           edihi=0.25d0*ftors(i)*difi**4
5314         else if (difi.lt.-drange(i)) then
5315           difi=difi+drange(i)
5316           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5317           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5318           edihi=0.25d0*ftors(i)*difi**4
5319         else
5320           difi=0.0d0
5321         endif
5322         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5323      &    i,itori,rad2deg*phii,
5324      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5325 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5326 c     &    drange(i),edihi
5327 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5328 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5329       enddo
5330 !      write (iout,*) 'edihcnstr',edihcnstr
5331       return
5332       end
5333 c----------------------------------------------------------------------------
5334       subroutine etor_d(etors_d,fact2)
5335 C 6/23/01 Compute double torsional energy
5336       implicit real*8 (a-h,o-z)
5337       include 'DIMENSIONS'
5338       include 'DIMENSIONS.ZSCOPT'
5339       include 'COMMON.VAR'
5340       include 'COMMON.GEO'
5341       include 'COMMON.LOCAL'
5342       include 'COMMON.TORSION'
5343       include 'COMMON.INTERACT'
5344       include 'COMMON.DERIV'
5345       include 'COMMON.CHAIN'
5346       include 'COMMON.NAMES'
5347       include 'COMMON.IOUNITS'
5348       include 'COMMON.FFIELD'
5349       include 'COMMON.TORCNSTR'
5350       logical lprn
5351 C Set lprn=.true. for debugging
5352       lprn=.false.
5353 c     lprn=.true.
5354       etors_d=0.0D0
5355       do i=iphi_start,iphi_end-1
5356         if (i.le.3) cycle
5357 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5358 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5359          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5360      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5361      &  (itype(i+1).eq.ntyp1)) cycle
5362         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5363      &     goto 1215
5364         itori=itortyp(itype(i-2))
5365         itori1=itortyp(itype(i-1))
5366         itori2=itortyp(itype(i))
5367         phii=phi(i)
5368         phii1=phi(i+1)
5369         gloci1=0.0D0
5370         gloci2=0.0D0
5371         iblock=1
5372         if (iabs(itype(i+1)).eq.20) iblock=2
5373 C Regular cosine and sine terms
5374         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5375           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5376           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5377           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5378           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5379           cosphi1=dcos(j*phii)
5380           sinphi1=dsin(j*phii)
5381           cosphi2=dcos(j*phii1)
5382           sinphi2=dsin(j*phii1)
5383           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5384      &     v2cij*cosphi2+v2sij*sinphi2
5385           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5386           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5387         enddo
5388         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5389           do l=1,k-1
5390             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5391             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5392             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5393             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5394             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5395             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5396             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5397             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5398             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5399      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5400             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5401      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5402             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5403      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5404           enddo
5405         enddo
5406         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5407         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5408  1215   continue
5409       enddo
5410       return
5411       end
5412 #endif
5413 c------------------------------------------------------------------------------
5414       subroutine eback_sc_corr(esccor)
5415 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5416 c        conformational states; temporarily implemented as differences
5417 c        between UNRES torsional potentials (dependent on three types of
5418 c        residues) and the torsional potentials dependent on all 20 types
5419 c        of residues computed from AM1 energy surfaces of terminally-blocked
5420 c        amino-acid residues.
5421       implicit real*8 (a-h,o-z)
5422       include 'DIMENSIONS'
5423       include 'DIMENSIONS.ZSCOPT'
5424       include 'COMMON.VAR'
5425       include 'COMMON.GEO'
5426       include 'COMMON.LOCAL'
5427       include 'COMMON.TORSION'
5428       include 'COMMON.SCCOR'
5429       include 'COMMON.INTERACT'
5430       include 'COMMON.DERIV'
5431       include 'COMMON.CHAIN'
5432       include 'COMMON.NAMES'
5433       include 'COMMON.IOUNITS'
5434       include 'COMMON.FFIELD'
5435       include 'COMMON.CONTROL'
5436       logical lprn
5437 C Set lprn=.true. for debugging
5438       lprn=.false.
5439 c      lprn=.true.
5440 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5441       esccor=0.0D0
5442       do i=itau_start,itau_end
5443         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5444         esccor_ii=0.0D0
5445         isccori=isccortyp(itype(i-2))
5446         isccori1=isccortyp(itype(i-1))
5447         phii=phi(i)
5448         do intertyp=1,3 !intertyp
5449 cc Added 09 May 2012 (Adasko)
5450 cc  Intertyp means interaction type of backbone mainchain correlation:
5451 c   1 = SC...Ca...Ca...Ca
5452 c   2 = Ca...Ca...Ca...SC
5453 c   3 = SC...Ca...Ca...SCi
5454         gloci=0.0D0
5455         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5456      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5457      &      (itype(i-1).eq.ntyp1)))
5458      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5459      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5460      &     .or.(itype(i).eq.ntyp1)))
5461      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5462      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5463      &      (itype(i-3).eq.ntyp1)))) cycle
5464         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5465         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5466      & cycle
5467        do j=1,nterm_sccor(isccori,isccori1)
5468           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5469           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5470           cosphi=dcos(j*tauangle(intertyp,i))
5471           sinphi=dsin(j*tauangle(intertyp,i))
5472            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5473            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5474          enddo
5475 C      write (iout,*)"EBACK_SC_COR",esccor,i
5476 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5477 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5478 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5479         if (lprn)
5480      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5481      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5482      &  (v1sccor(j,1,itori,itori1),j=1,6)
5483      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5484 c        gsccor_loc(i-3)=gloci
5485        enddo !intertyp
5486       enddo
5487       return
5488       end
5489 c------------------------------------------------------------------------------
5490       subroutine multibody(ecorr)
5491 C This subroutine calculates multi-body contributions to energy following
5492 C the idea of Skolnick et al. If side chains I and J make a contact and
5493 C at the same time side chains I+1 and J+1 make a contact, an extra
5494 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5495       implicit real*8 (a-h,o-z)
5496       include 'DIMENSIONS'
5497       include 'COMMON.IOUNITS'
5498       include 'COMMON.DERIV'
5499       include 'COMMON.INTERACT'
5500       include 'COMMON.CONTACTS'
5501       double precision gx(3),gx1(3)
5502       logical lprn
5503
5504 C Set lprn=.true. for debugging
5505       lprn=.false.
5506
5507       if (lprn) then
5508         write (iout,'(a)') 'Contact function values:'
5509         do i=nnt,nct-2
5510           write (iout,'(i2,20(1x,i2,f10.5))')
5511      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5512         enddo
5513       endif
5514       ecorr=0.0D0
5515       do i=nnt,nct
5516         do j=1,3
5517           gradcorr(j,i)=0.0D0
5518           gradxorr(j,i)=0.0D0
5519         enddo
5520       enddo
5521       do i=nnt,nct-2
5522
5523         DO ISHIFT = 3,4
5524
5525         i1=i+ishift
5526         num_conti=num_cont(i)
5527         num_conti1=num_cont(i1)
5528         do jj=1,num_conti
5529           j=jcont(jj,i)
5530           do kk=1,num_conti1
5531             j1=jcont(kk,i1)
5532             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5533 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5534 cd   &                   ' ishift=',ishift
5535 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5536 C The system gains extra energy.
5537               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5538             endif   ! j1==j+-ishift
5539           enddo     ! kk
5540         enddo       ! jj
5541
5542         ENDDO ! ISHIFT
5543
5544       enddo         ! i
5545       return
5546       end
5547 c------------------------------------------------------------------------------
5548       double precision function esccorr(i,j,k,l,jj,kk)
5549       implicit real*8 (a-h,o-z)
5550       include 'DIMENSIONS'
5551       include 'COMMON.IOUNITS'
5552       include 'COMMON.DERIV'
5553       include 'COMMON.INTERACT'
5554       include 'COMMON.CONTACTS'
5555       double precision gx(3),gx1(3)
5556       logical lprn
5557       lprn=.false.
5558       eij=facont(jj,i)
5559       ekl=facont(kk,k)
5560 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5561 C Calculate the multi-body contribution to energy.
5562 C Calculate multi-body contributions to the gradient.
5563 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5564 cd   & k,l,(gacont(m,kk,k),m=1,3)
5565       do m=1,3
5566         gx(m) =ekl*gacont(m,jj,i)
5567         gx1(m)=eij*gacont(m,kk,k)
5568         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5569         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5570         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5571         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5572       enddo
5573       do m=i,j-1
5574         do ll=1,3
5575           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5576         enddo
5577       enddo
5578       do m=k,l-1
5579         do ll=1,3
5580           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5581         enddo
5582       enddo
5583       esccorr=-eij*ekl
5584       return
5585       end
5586 c------------------------------------------------------------------------------
5587 #ifdef MPL
5588       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5589       implicit real*8 (a-h,o-z)
5590       include 'DIMENSIONS'
5591       integer dimen1,dimen2,atom,indx
5592       double precision buffer(dimen1,dimen2)
5593       double precision zapas
5594       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5595      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5596      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5597       num_kont=num_cont_hb(atom)
5598       do i=1,num_kont
5599         do k=1,7
5600           do j=1,3
5601             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5602           enddo ! j
5603         enddo ! k
5604         buffer(i,indx+22)=facont_hb(i,atom)
5605         buffer(i,indx+23)=ees0p(i,atom)
5606         buffer(i,indx+24)=ees0m(i,atom)
5607         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5608       enddo ! i
5609       buffer(1,indx+26)=dfloat(num_kont)
5610       return
5611       end
5612 c------------------------------------------------------------------------------
5613       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5614       implicit real*8 (a-h,o-z)
5615       include 'DIMENSIONS'
5616       integer dimen1,dimen2,atom,indx
5617       double precision buffer(dimen1,dimen2)
5618       double precision zapas
5619       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5620      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5621      &         ees0m(ntyp,maxres),
5622      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5623       num_kont=buffer(1,indx+26)
5624       num_kont_old=num_cont_hb(atom)
5625       num_cont_hb(atom)=num_kont+num_kont_old
5626       do i=1,num_kont
5627         ii=i+num_kont_old
5628         do k=1,7
5629           do j=1,3
5630             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5631           enddo ! j
5632         enddo ! k
5633         facont_hb(ii,atom)=buffer(i,indx+22)
5634         ees0p(ii,atom)=buffer(i,indx+23)
5635         ees0m(ii,atom)=buffer(i,indx+24)
5636         jcont_hb(ii,atom)=buffer(i,indx+25)
5637       enddo ! i
5638       return
5639       end
5640 c------------------------------------------------------------------------------
5641 #endif
5642       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5643 C This subroutine calculates multi-body contributions to hydrogen-bonding
5644       implicit real*8 (a-h,o-z)
5645       include 'DIMENSIONS'
5646       include 'DIMENSIONS.ZSCOPT'
5647       include 'COMMON.IOUNITS'
5648 #ifdef MPL
5649       include 'COMMON.INFO'
5650 #endif
5651       include 'COMMON.FFIELD'
5652       include 'COMMON.DERIV'
5653       include 'COMMON.INTERACT'
5654       include 'COMMON.CONTACTS'
5655 #ifdef MPL
5656       parameter (max_cont=maxconts)
5657       parameter (max_dim=2*(8*3+2))
5658       parameter (msglen1=max_cont*max_dim*4)
5659       parameter (msglen2=2*msglen1)
5660       integer source,CorrelType,CorrelID,Error
5661       double precision buffer(max_cont,max_dim)
5662 #endif
5663       double precision gx(3),gx1(3)
5664       logical lprn,ldone
5665
5666 C Set lprn=.true. for debugging
5667       lprn=.false.
5668 #ifdef MPL
5669       n_corr=0
5670       n_corr1=0
5671       if (fgProcs.le.1) goto 30
5672       if (lprn) then
5673         write (iout,'(a)') 'Contact function values:'
5674         do i=nnt,nct-2
5675           write (iout,'(2i3,50(1x,i2,f5.2))')
5676      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5677      &    j=1,num_cont_hb(i))
5678         enddo
5679       endif
5680 C Caution! Following code assumes that electrostatic interactions concerning
5681 C a given atom are split among at most two processors!
5682       CorrelType=477
5683       CorrelID=MyID+1
5684       ldone=.false.
5685       do i=1,max_cont
5686         do j=1,max_dim
5687           buffer(i,j)=0.0D0
5688         enddo
5689       enddo
5690       mm=mod(MyRank,2)
5691 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5692       if (mm) 20,20,10
5693    10 continue
5694 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5695       if (MyRank.gt.0) then
5696 C Send correlation contributions to the preceding processor
5697         msglen=msglen1
5698         nn=num_cont_hb(iatel_s)
5699         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5700 cd      write (iout,*) 'The BUFFER array:'
5701 cd      do i=1,nn
5702 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5703 cd      enddo
5704         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5705           msglen=msglen2
5706             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5707 C Clear the contacts of the atom passed to the neighboring processor
5708         nn=num_cont_hb(iatel_s+1)
5709 cd      do i=1,nn
5710 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5711 cd      enddo
5712             num_cont_hb(iatel_s)=0
5713         endif
5714 cd      write (iout,*) 'Processor ',MyID,MyRank,
5715 cd   & ' is sending correlation contribution to processor',MyID-1,
5716 cd   & ' msglen=',msglen
5717 cd      write (*,*) 'Processor ',MyID,MyRank,
5718 cd   & ' is sending correlation contribution to processor',MyID-1,
5719 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5720         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5721 cd      write (iout,*) 'Processor ',MyID,
5722 cd   & ' has sent correlation contribution to processor',MyID-1,
5723 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5724 cd      write (*,*) 'Processor ',MyID,
5725 cd   & ' has sent correlation contribution to processor',MyID-1,
5726 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5727         msglen=msglen1
5728       endif ! (MyRank.gt.0)
5729       if (ldone) goto 30
5730       ldone=.true.
5731    20 continue
5732 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5733       if (MyRank.lt.fgProcs-1) then
5734 C Receive correlation contributions from the next processor
5735         msglen=msglen1
5736         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5737 cd      write (iout,*) 'Processor',MyID,
5738 cd   & ' is receiving correlation contribution from processor',MyID+1,
5739 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5740 cd      write (*,*) 'Processor',MyID,
5741 cd   & ' is receiving correlation contribution from processor',MyID+1,
5742 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5743         nbytes=-1
5744         do while (nbytes.le.0)
5745           call mp_probe(MyID+1,CorrelType,nbytes)
5746         enddo
5747 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5748         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5749 cd      write (iout,*) 'Processor',MyID,
5750 cd   & ' has received correlation contribution from processor',MyID+1,
5751 cd   & ' msglen=',msglen,' nbytes=',nbytes
5752 cd      write (iout,*) 'The received BUFFER array:'
5753 cd      do i=1,max_cont
5754 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5755 cd      enddo
5756         if (msglen.eq.msglen1) then
5757           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5758         else if (msglen.eq.msglen2)  then
5759           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5760           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5761         else
5762           write (iout,*)
5763      & 'ERROR!!!! message length changed while processing correlations.'
5764           write (*,*)
5765      & 'ERROR!!!! message length changed while processing correlations.'
5766           call mp_stopall(Error)
5767         endif ! msglen.eq.msglen1
5768       endif ! MyRank.lt.fgProcs-1
5769       if (ldone) goto 30
5770       ldone=.true.
5771       goto 10
5772    30 continue
5773 #endif
5774       if (lprn) then
5775         write (iout,'(a)') 'Contact function values:'
5776         do i=nnt,nct-2
5777           write (iout,'(2i3,50(1x,i2,f5.2))')
5778      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5779      &    j=1,num_cont_hb(i))
5780         enddo
5781       endif
5782       ecorr=0.0D0
5783 C Remove the loop below after debugging !!!
5784       do i=nnt,nct
5785         do j=1,3
5786           gradcorr(j,i)=0.0D0
5787           gradxorr(j,i)=0.0D0
5788         enddo
5789       enddo
5790 C Calculate the local-electrostatic correlation terms
5791       do i=iatel_s,iatel_e+1
5792         i1=i+1
5793         num_conti=num_cont_hb(i)
5794         num_conti1=num_cont_hb(i+1)
5795         do jj=1,num_conti
5796           j=jcont_hb(jj,i)
5797           do kk=1,num_conti1
5798             j1=jcont_hb(kk,i1)
5799 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5800 c     &         ' jj=',jj,' kk=',kk
5801             if (j1.eq.j+1 .or. j1.eq.j-1) then
5802 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5803 C The system gains extra energy.
5804               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5805               n_corr=n_corr+1
5806             else if (j1.eq.j) then
5807 C Contacts I-J and I-(J+1) occur simultaneously.
5808 C The system loses extra energy.
5809 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5810             endif
5811           enddo ! kk
5812           do kk=1,num_conti
5813             j1=jcont_hb(kk,i)
5814 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5815 c    &         ' jj=',jj,' kk=',kk
5816             if (j1.eq.j+1) then
5817 C Contacts I-J and (I+1)-J occur simultaneously.
5818 C The system loses extra energy.
5819 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5820             endif ! j1==j+1
5821           enddo ! kk
5822         enddo ! jj
5823       enddo ! i
5824       return
5825       end
5826 c------------------------------------------------------------------------------
5827       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5828      &  n_corr1)
5829 C This subroutine calculates multi-body contributions to hydrogen-bonding
5830       implicit real*8 (a-h,o-z)
5831       include 'DIMENSIONS'
5832       include 'DIMENSIONS.ZSCOPT'
5833       include 'COMMON.IOUNITS'
5834 #ifdef MPL
5835       include 'COMMON.INFO'
5836 #endif
5837       include 'COMMON.FFIELD'
5838       include 'COMMON.DERIV'
5839       include 'COMMON.INTERACT'
5840       include 'COMMON.CONTACTS'
5841 #ifdef MPL
5842       parameter (max_cont=maxconts)
5843       parameter (max_dim=2*(8*3+2))
5844       parameter (msglen1=max_cont*max_dim*4)
5845       parameter (msglen2=2*msglen1)
5846       integer source,CorrelType,CorrelID,Error
5847       double precision buffer(max_cont,max_dim)
5848 #endif
5849       double precision gx(3),gx1(3)
5850       logical lprn,ldone
5851
5852 C Set lprn=.true. for debugging
5853       lprn=.false.
5854       eturn6=0.0d0
5855       ecorr6=0.0d0
5856 #ifdef MPL
5857       n_corr=0
5858       n_corr1=0
5859       if (fgProcs.le.1) goto 30
5860       if (lprn) then
5861         write (iout,'(a)') 'Contact function values:'
5862         do i=nnt,nct-2
5863           write (iout,'(2i3,50(1x,i2,f5.2))')
5864      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5865      &    j=1,num_cont_hb(i))
5866         enddo
5867       endif
5868 C Caution! Following code assumes that electrostatic interactions concerning
5869 C a given atom are split among at most two processors!
5870       CorrelType=477
5871       CorrelID=MyID+1
5872       ldone=.false.
5873       do i=1,max_cont
5874         do j=1,max_dim
5875           buffer(i,j)=0.0D0
5876         enddo
5877       enddo
5878       mm=mod(MyRank,2)
5879 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5880       if (mm) 20,20,10
5881    10 continue
5882 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5883       if (MyRank.gt.0) then
5884 C Send correlation contributions to the preceding processor
5885         msglen=msglen1
5886         nn=num_cont_hb(iatel_s)
5887         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5888 cd      write (iout,*) 'The BUFFER array:'
5889 cd      do i=1,nn
5890 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5891 cd      enddo
5892         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5893           msglen=msglen2
5894             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5895 C Clear the contacts of the atom passed to the neighboring processor
5896         nn=num_cont_hb(iatel_s+1)
5897 cd      do i=1,nn
5898 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5899 cd      enddo
5900             num_cont_hb(iatel_s)=0
5901         endif
5902 cd      write (iout,*) 'Processor ',MyID,MyRank,
5903 cd   & ' is sending correlation contribution to processor',MyID-1,
5904 cd   & ' msglen=',msglen
5905 cd      write (*,*) 'Processor ',MyID,MyRank,
5906 cd   & ' is sending correlation contribution to processor',MyID-1,
5907 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5908         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5909 cd      write (iout,*) 'Processor ',MyID,
5910 cd   & ' has sent correlation contribution to processor',MyID-1,
5911 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5912 cd      write (*,*) 'Processor ',MyID,
5913 cd   & ' has sent correlation contribution to processor',MyID-1,
5914 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5915         msglen=msglen1
5916       endif ! (MyRank.gt.0)
5917       if (ldone) goto 30
5918       ldone=.true.
5919    20 continue
5920 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5921       if (MyRank.lt.fgProcs-1) then
5922 C Receive correlation contributions from the next processor
5923         msglen=msglen1
5924         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5925 cd      write (iout,*) 'Processor',MyID,
5926 cd   & ' is receiving correlation contribution from processor',MyID+1,
5927 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5928 cd      write (*,*) 'Processor',MyID,
5929 cd   & ' is receiving correlation contribution from processor',MyID+1,
5930 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5931         nbytes=-1
5932         do while (nbytes.le.0)
5933           call mp_probe(MyID+1,CorrelType,nbytes)
5934         enddo
5935 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5936         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5937 cd      write (iout,*) 'Processor',MyID,
5938 cd   & ' has received correlation contribution from processor',MyID+1,
5939 cd   & ' msglen=',msglen,' nbytes=',nbytes
5940 cd      write (iout,*) 'The received BUFFER array:'
5941 cd      do i=1,max_cont
5942 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5943 cd      enddo
5944         if (msglen.eq.msglen1) then
5945           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5946         else if (msglen.eq.msglen2)  then
5947           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5948           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5949         else
5950           write (iout,*)
5951      & 'ERROR!!!! message length changed while processing correlations.'
5952           write (*,*)
5953      & 'ERROR!!!! message length changed while processing correlations.'
5954           call mp_stopall(Error)
5955         endif ! msglen.eq.msglen1
5956       endif ! MyRank.lt.fgProcs-1
5957       if (ldone) goto 30
5958       ldone=.true.
5959       goto 10
5960    30 continue
5961 #endif
5962       if (lprn) then
5963         write (iout,'(a)') 'Contact function values:'
5964         do i=nnt,nct-2
5965           write (iout,'(2i3,50(1x,i2,f5.2))')
5966      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5967      &    j=1,num_cont_hb(i))
5968         enddo
5969       endif
5970       ecorr=0.0D0
5971       ecorr5=0.0d0
5972       ecorr6=0.0d0
5973 C Remove the loop below after debugging !!!
5974       do i=nnt,nct
5975         do j=1,3
5976           gradcorr(j,i)=0.0D0
5977           gradxorr(j,i)=0.0D0
5978         enddo
5979       enddo
5980 C Calculate the dipole-dipole interaction energies
5981       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5982       do i=iatel_s,iatel_e+1
5983         num_conti=num_cont_hb(i)
5984         do jj=1,num_conti
5985           j=jcont_hb(jj,i)
5986           call dipole(i,j,jj)
5987         enddo
5988       enddo
5989       endif
5990 C Calculate the local-electrostatic correlation terms
5991       do i=iatel_s,iatel_e+1
5992         i1=i+1
5993         num_conti=num_cont_hb(i)
5994         num_conti1=num_cont_hb(i+1)
5995         do jj=1,num_conti
5996           j=jcont_hb(jj,i)
5997           do kk=1,num_conti1
5998             j1=jcont_hb(kk,i1)
5999 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6000 c     &         ' jj=',jj,' kk=',kk
6001             if (j1.eq.j+1 .or. j1.eq.j-1) then
6002 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6003 C The system gains extra energy.
6004               n_corr=n_corr+1
6005               sqd1=dsqrt(d_cont(jj,i))
6006               sqd2=dsqrt(d_cont(kk,i1))
6007               sred_geom = sqd1*sqd2
6008               IF (sred_geom.lt.cutoff_corr) THEN
6009                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6010      &            ekont,fprimcont)
6011 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6012 c     &         ' jj=',jj,' kk=',kk
6013                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6014                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6015                 do l=1,3
6016                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6017                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6018                 enddo
6019                 n_corr1=n_corr1+1
6020 cd               write (iout,*) 'sred_geom=',sred_geom,
6021 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6022                 call calc_eello(i,j,i+1,j1,jj,kk)
6023                 if (wcorr4.gt.0.0d0)
6024      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6025                 if (wcorr5.gt.0.0d0)
6026      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6027 c                print *,"wcorr5",ecorr5
6028 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6029 cd                write(2,*)'ijkl',i,j,i+1,j1
6030                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6031      &               .or. wturn6.eq.0.0d0))then
6032 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6033                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6034 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6035 cd     &            'ecorr6=',ecorr6
6036 cd                write (iout,'(4e15.5)') sred_geom,
6037 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6038 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6039 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6040                 else if (wturn6.gt.0.0d0
6041      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6042 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6043                   eturn6=eturn6+eello_turn6(i,jj,kk)
6044 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6045                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6046                    eturn6=0.0d0
6047                    ecorr6=0.0d0
6048                 endif
6049
6050               ENDIF
6051 1111          continue
6052             else if (j1.eq.j) then
6053 C Contacts I-J and I-(J+1) occur simultaneously.
6054 C The system loses extra energy.
6055 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6056             endif
6057           enddo ! kk
6058           do kk=1,num_conti
6059             j1=jcont_hb(kk,i)
6060 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6061 c    &         ' jj=',jj,' kk=',kk
6062             if (j1.eq.j+1) then
6063 C Contacts I-J and (I+1)-J occur simultaneously.
6064 C The system loses extra energy.
6065 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6066             endif ! j1==j+1
6067           enddo ! kk
6068         enddo ! jj
6069       enddo ! i
6070       write (iout,*) "eturn6",eturn6,ecorr6
6071       return
6072       end
6073 c------------------------------------------------------------------------------
6074       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6075       implicit real*8 (a-h,o-z)
6076       include 'DIMENSIONS'
6077       include 'COMMON.IOUNITS'
6078       include 'COMMON.DERIV'
6079       include 'COMMON.INTERACT'
6080       include 'COMMON.CONTACTS'
6081       include 'COMMON.CONTROL'
6082       include 'COMMON.SHIELD'
6083       double precision gx(3),gx1(3)
6084       logical lprn
6085       lprn=.false.
6086       eij=facont_hb(jj,i)
6087       ekl=facont_hb(kk,k)
6088       ees0pij=ees0p(jj,i)
6089       ees0pkl=ees0p(kk,k)
6090       ees0mij=ees0m(jj,i)
6091       ees0mkl=ees0m(kk,k)
6092       ekont=eij*ekl
6093       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6094 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6095 C Following 4 lines for diagnostics.
6096 cd    ees0pkl=0.0D0
6097 cd    ees0pij=1.0D0
6098 cd    ees0mkl=0.0D0
6099 cd    ees0mij=1.0D0
6100 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6101 c    &   ' and',k,l
6102 c     write (iout,*)'Contacts have occurred for peptide groups',
6103 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6104 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6105 C Calculate the multi-body contribution to energy.
6106 C      ecorr=ecorr+ekont*ees
6107       if (calc_grad) then
6108 C Calculate multi-body contributions to the gradient.
6109       do ll=1,3
6110         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6111         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6112      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6113      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6114         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6115      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6116      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6117         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6118         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6119      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6120      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6121         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6122      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6123      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6124       enddo
6125       do m=i+1,j-1
6126         do ll=1,3
6127           gradcorr(ll,m)=gradcorr(ll,m)+
6128      &     ees*ekl*gacont_hbr(ll,jj,i)-
6129      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6130      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6131         enddo
6132       enddo
6133       do m=k+1,l-1
6134         do ll=1,3
6135           gradcorr(ll,m)=gradcorr(ll,m)+
6136      &     ees*eij*gacont_hbr(ll,kk,k)-
6137      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6138      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6139         enddo
6140       enddo
6141       if (shield_mode.gt.0) then
6142        j=ees0plist(jj,i)
6143        l=ees0plist(kk,k)
6144 C        print *,i,j,fac_shield(i),fac_shield(j),
6145 C     &fac_shield(k),fac_shield(l)
6146         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6147      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6148           do ilist=1,ishield_list(i)
6149            iresshield=shield_list(ilist,i)
6150            do m=1,3
6151            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6152 C     &      *2.0
6153            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6154      &              rlocshield
6155      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6156             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6157      &+rlocshield
6158            enddo
6159           enddo
6160           do ilist=1,ishield_list(j)
6161            iresshield=shield_list(ilist,j)
6162            do m=1,3
6163            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6164 C     &     *2.0
6165            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6166      &              rlocshield
6167      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6168            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6169      &     +rlocshield
6170            enddo
6171           enddo
6172           do ilist=1,ishield_list(k)
6173            iresshield=shield_list(ilist,k)
6174            do m=1,3
6175            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6176 C     &     *2.0
6177            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6178      &              rlocshield
6179      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6180            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6181      &     +rlocshield
6182            enddo
6183           enddo
6184           do ilist=1,ishield_list(l)
6185            iresshield=shield_list(ilist,l)
6186            do m=1,3
6187            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6188 C     &     *2.0
6189            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6190      &              rlocshield
6191      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6192            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6193      &     +rlocshield
6194            enddo
6195           enddo
6196 C          print *,gshieldx(m,iresshield)
6197           do m=1,3
6198             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6199      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6200             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6201      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6202             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6203      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6204             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6205      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6206
6207             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6208      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6209             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6210      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6211             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6212      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6213             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6214      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6215
6216            enddo
6217       endif
6218       endif
6219       endif
6220       ehbcorr=ekont*ees
6221       return
6222       end
6223 C---------------------------------------------------------------------------
6224       subroutine dipole(i,j,jj)
6225       implicit real*8 (a-h,o-z)
6226       include 'DIMENSIONS'
6227       include 'DIMENSIONS.ZSCOPT'
6228       include 'COMMON.IOUNITS'
6229       include 'COMMON.CHAIN'
6230       include 'COMMON.FFIELD'
6231       include 'COMMON.DERIV'
6232       include 'COMMON.INTERACT'
6233       include 'COMMON.CONTACTS'
6234       include 'COMMON.TORSION'
6235       include 'COMMON.VAR'
6236       include 'COMMON.GEO'
6237       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6238      &  auxmat(2,2)
6239       iti1 = itortyp(itype(i+1))
6240       if (j.lt.nres-1) then
6241         if (itype(j).le.ntyp) then
6242           itj1 = itortyp(itype(j+1))
6243         else
6244           itj=ntortyp+1
6245         endif
6246       else
6247         itj1=ntortyp+1
6248       endif
6249       do iii=1,2
6250         dipi(iii,1)=Ub2(iii,i)
6251         dipderi(iii)=Ub2der(iii,i)
6252         dipi(iii,2)=b1(iii,iti1)
6253         dipj(iii,1)=Ub2(iii,j)
6254         dipderj(iii)=Ub2der(iii,j)
6255         dipj(iii,2)=b1(iii,itj1)
6256       enddo
6257       kkk=0
6258       do iii=1,2
6259         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6260         do jjj=1,2
6261           kkk=kkk+1
6262           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6263         enddo
6264       enddo
6265       if (.not.calc_grad) return
6266       do kkk=1,5
6267         do lll=1,3
6268           mmm=0
6269           do iii=1,2
6270             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6271      &        auxvec(1))
6272             do jjj=1,2
6273               mmm=mmm+1
6274               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6275             enddo
6276           enddo
6277         enddo
6278       enddo
6279       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6280       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6281       do iii=1,2
6282         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6283       enddo
6284       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6285       do iii=1,2
6286         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6287       enddo
6288       return
6289       end
6290 C---------------------------------------------------------------------------
6291       subroutine calc_eello(i,j,k,l,jj,kk)
6292 C
6293 C This subroutine computes matrices and vectors needed to calculate
6294 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6295 C
6296       implicit real*8 (a-h,o-z)
6297       include 'DIMENSIONS'
6298       include 'DIMENSIONS.ZSCOPT'
6299       include 'COMMON.IOUNITS'
6300       include 'COMMON.CHAIN'
6301       include 'COMMON.DERIV'
6302       include 'COMMON.INTERACT'
6303       include 'COMMON.CONTACTS'
6304       include 'COMMON.TORSION'
6305       include 'COMMON.VAR'
6306       include 'COMMON.GEO'
6307       include 'COMMON.FFIELD'
6308       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6309      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6310       logical lprn
6311       common /kutas/ lprn
6312 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6313 cd     & ' jj=',jj,' kk=',kk
6314 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6315       do iii=1,2
6316         do jjj=1,2
6317           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6318           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6319         enddo
6320       enddo
6321       call transpose2(aa1(1,1),aa1t(1,1))
6322       call transpose2(aa2(1,1),aa2t(1,1))
6323       do kkk=1,5
6324         do lll=1,3
6325           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6326      &      aa1tder(1,1,lll,kkk))
6327           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6328      &      aa2tder(1,1,lll,kkk))
6329         enddo
6330       enddo
6331       if (l.eq.j+1) then
6332 C parallel orientation of the two CA-CA-CA frames.
6333         if (i.gt.1 .and. itype(i).le.ntyp) then
6334           iti=itortyp(itype(i))
6335         else
6336           iti=ntortyp+1
6337         endif
6338         itk1=itortyp(itype(k+1))
6339         itj=itortyp(itype(j))
6340         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6341           itl1=itortyp(itype(l+1))
6342         else
6343           itl1=ntortyp+1
6344         endif
6345 C A1 kernel(j+1) A2T
6346 cd        do iii=1,2
6347 cd          write (iout,'(3f10.5,5x,3f10.5)')
6348 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6349 cd        enddo
6350         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6351      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6352      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6353 C Following matrices are needed only for 6-th order cumulants
6354         IF (wcorr6.gt.0.0d0) THEN
6355         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6356      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6357      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6358         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6359      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6360      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6361      &   ADtEAderx(1,1,1,1,1,1))
6362         lprn=.false.
6363         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6364      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6365      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6366      &   ADtEA1derx(1,1,1,1,1,1))
6367         ENDIF
6368 C End 6-th order cumulants
6369 cd        lprn=.false.
6370 cd        if (lprn) then
6371 cd        write (2,*) 'In calc_eello6'
6372 cd        do iii=1,2
6373 cd          write (2,*) 'iii=',iii
6374 cd          do kkk=1,5
6375 cd            write (2,*) 'kkk=',kkk
6376 cd            do jjj=1,2
6377 cd              write (2,'(3(2f10.5),5x)')
6378 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6379 cd            enddo
6380 cd          enddo
6381 cd        enddo
6382 cd        endif
6383         call transpose2(EUgder(1,1,k),auxmat(1,1))
6384         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6385         call transpose2(EUg(1,1,k),auxmat(1,1))
6386         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6387         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6388         do iii=1,2
6389           do kkk=1,5
6390             do lll=1,3
6391               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6392      &          EAEAderx(1,1,lll,kkk,iii,1))
6393             enddo
6394           enddo
6395         enddo
6396 C A1T kernel(i+1) A2
6397         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6398      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6399      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6400 C Following matrices are needed only for 6-th order cumulants
6401         IF (wcorr6.gt.0.0d0) THEN
6402         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6403      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6404      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6405         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6406      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6407      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6408      &   ADtEAderx(1,1,1,1,1,2))
6409         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6410      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6411      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6412      &   ADtEA1derx(1,1,1,1,1,2))
6413         ENDIF
6414 C End 6-th order cumulants
6415         call transpose2(EUgder(1,1,l),auxmat(1,1))
6416         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6417         call transpose2(EUg(1,1,l),auxmat(1,1))
6418         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6419         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6420         do iii=1,2
6421           do kkk=1,5
6422             do lll=1,3
6423               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6424      &          EAEAderx(1,1,lll,kkk,iii,2))
6425             enddo
6426           enddo
6427         enddo
6428 C AEAb1 and AEAb2
6429 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6430 C They are needed only when the fifth- or the sixth-order cumulants are
6431 C indluded.
6432         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6433         call transpose2(AEA(1,1,1),auxmat(1,1))
6434         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6435         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6436         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6437         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6438         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6439         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6440         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6441         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6442         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6443         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6444         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6445         call transpose2(AEA(1,1,2),auxmat(1,1))
6446         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6447         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6448         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6449         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6450         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6451         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6452         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6453         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6454         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6455         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6456         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6457 C Calculate the Cartesian derivatives of the vectors.
6458         do iii=1,2
6459           do kkk=1,5
6460             do lll=1,3
6461               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6462               call matvec2(auxmat(1,1),b1(1,iti),
6463      &          AEAb1derx(1,lll,kkk,iii,1,1))
6464               call matvec2(auxmat(1,1),Ub2(1,i),
6465      &          AEAb2derx(1,lll,kkk,iii,1,1))
6466               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6467      &          AEAb1derx(1,lll,kkk,iii,2,1))
6468               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6469      &          AEAb2derx(1,lll,kkk,iii,2,1))
6470               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6471               call matvec2(auxmat(1,1),b1(1,itj),
6472      &          AEAb1derx(1,lll,kkk,iii,1,2))
6473               call matvec2(auxmat(1,1),Ub2(1,j),
6474      &          AEAb2derx(1,lll,kkk,iii,1,2))
6475               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6476      &          AEAb1derx(1,lll,kkk,iii,2,2))
6477               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6478      &          AEAb2derx(1,lll,kkk,iii,2,2))
6479             enddo
6480           enddo
6481         enddo
6482         ENDIF
6483 C End vectors
6484       else
6485 C Antiparallel orientation of the two CA-CA-CA frames.
6486         if (i.gt.1 .and. itype(i).le.ntyp) then
6487           iti=itortyp(itype(i))
6488         else
6489           iti=ntortyp+1
6490         endif
6491         itk1=itortyp(itype(k+1))
6492         itl=itortyp(itype(l))
6493         itj=itortyp(itype(j))
6494         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6495           itj1=itortyp(itype(j+1))
6496         else
6497           itj1=ntortyp+1
6498         endif
6499 C A2 kernel(j-1)T A1T
6500         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6501      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6502      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6503 C Following matrices are needed only for 6-th order cumulants
6504         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6505      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6506         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6507      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6508      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6509         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6510      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6511      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6512      &   ADtEAderx(1,1,1,1,1,1))
6513         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6514      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6515      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6516      &   ADtEA1derx(1,1,1,1,1,1))
6517         ENDIF
6518 C End 6-th order cumulants
6519         call transpose2(EUgder(1,1,k),auxmat(1,1))
6520         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6521         call transpose2(EUg(1,1,k),auxmat(1,1))
6522         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6523         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6524         do iii=1,2
6525           do kkk=1,5
6526             do lll=1,3
6527               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6528      &          EAEAderx(1,1,lll,kkk,iii,1))
6529             enddo
6530           enddo
6531         enddo
6532 C A2T kernel(i+1)T A1
6533         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6534      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6535      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6536 C Following matrices are needed only for 6-th order cumulants
6537         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6538      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6539         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6540      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6541      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6542         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6543      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6544      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6545      &   ADtEAderx(1,1,1,1,1,2))
6546         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6547      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6548      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6549      &   ADtEA1derx(1,1,1,1,1,2))
6550         ENDIF
6551 C End 6-th order cumulants
6552         call transpose2(EUgder(1,1,j),auxmat(1,1))
6553         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6554         call transpose2(EUg(1,1,j),auxmat(1,1))
6555         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6556         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6557         do iii=1,2
6558           do kkk=1,5
6559             do lll=1,3
6560               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6561      &          EAEAderx(1,1,lll,kkk,iii,2))
6562             enddo
6563           enddo
6564         enddo
6565 C AEAb1 and AEAb2
6566 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6567 C They are needed only when the fifth- or the sixth-order cumulants are
6568 C indluded.
6569         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6570      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6571         call transpose2(AEA(1,1,1),auxmat(1,1))
6572         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6573         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6574         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6575         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6576         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6577         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6578         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6579         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6580         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6581         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6582         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6583         call transpose2(AEA(1,1,2),auxmat(1,1))
6584         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6585         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6586         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6587         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6588         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6589         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6590         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6591         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6592         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6593         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6594         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6595 C Calculate the Cartesian derivatives of the vectors.
6596         do iii=1,2
6597           do kkk=1,5
6598             do lll=1,3
6599               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6600               call matvec2(auxmat(1,1),b1(1,iti),
6601      &          AEAb1derx(1,lll,kkk,iii,1,1))
6602               call matvec2(auxmat(1,1),Ub2(1,i),
6603      &          AEAb2derx(1,lll,kkk,iii,1,1))
6604               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6605      &          AEAb1derx(1,lll,kkk,iii,2,1))
6606               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6607      &          AEAb2derx(1,lll,kkk,iii,2,1))
6608               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6609               call matvec2(auxmat(1,1),b1(1,itl),
6610      &          AEAb1derx(1,lll,kkk,iii,1,2))
6611               call matvec2(auxmat(1,1),Ub2(1,l),
6612      &          AEAb2derx(1,lll,kkk,iii,1,2))
6613               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6614      &          AEAb1derx(1,lll,kkk,iii,2,2))
6615               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6616      &          AEAb2derx(1,lll,kkk,iii,2,2))
6617             enddo
6618           enddo
6619         enddo
6620         ENDIF
6621 C End vectors
6622       endif
6623       return
6624       end
6625 C---------------------------------------------------------------------------
6626       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6627      &  KK,KKderg,AKA,AKAderg,AKAderx)
6628       implicit none
6629       integer nderg
6630       logical transp
6631       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6632      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6633      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6634       integer iii,kkk,lll
6635       integer jjj,mmm
6636       logical lprn
6637       common /kutas/ lprn
6638       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6639       do iii=1,nderg
6640         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6641      &    AKAderg(1,1,iii))
6642       enddo
6643 cd      if (lprn) write (2,*) 'In kernel'
6644       do kkk=1,5
6645 cd        if (lprn) write (2,*) 'kkk=',kkk
6646         do lll=1,3
6647           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6648      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6649 cd          if (lprn) then
6650 cd            write (2,*) 'lll=',lll
6651 cd            write (2,*) 'iii=1'
6652 cd            do jjj=1,2
6653 cd              write (2,'(3(2f10.5),5x)')
6654 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6655 cd            enddo
6656 cd          endif
6657           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6658      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6659 cd          if (lprn) then
6660 cd            write (2,*) 'lll=',lll
6661 cd            write (2,*) 'iii=2'
6662 cd            do jjj=1,2
6663 cd              write (2,'(3(2f10.5),5x)')
6664 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6665 cd            enddo
6666 cd          endif
6667         enddo
6668       enddo
6669       return
6670       end
6671 C---------------------------------------------------------------------------
6672       double precision function eello4(i,j,k,l,jj,kk)
6673       implicit real*8 (a-h,o-z)
6674       include 'DIMENSIONS'
6675       include 'DIMENSIONS.ZSCOPT'
6676       include 'COMMON.IOUNITS'
6677       include 'COMMON.CHAIN'
6678       include 'COMMON.DERIV'
6679       include 'COMMON.INTERACT'
6680       include 'COMMON.CONTACTS'
6681       include 'COMMON.TORSION'
6682       include 'COMMON.VAR'
6683       include 'COMMON.GEO'
6684       double precision pizda(2,2),ggg1(3),ggg2(3)
6685 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6686 cd        eello4=0.0d0
6687 cd        return
6688 cd      endif
6689 cd      print *,'eello4:',i,j,k,l,jj,kk
6690 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6691 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6692 cold      eij=facont_hb(jj,i)
6693 cold      ekl=facont_hb(kk,k)
6694 cold      ekont=eij*ekl
6695       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6696       if (calc_grad) then
6697 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6698       gcorr_loc(k-1)=gcorr_loc(k-1)
6699      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6700       if (l.eq.j+1) then
6701         gcorr_loc(l-1)=gcorr_loc(l-1)
6702      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6703       else
6704         gcorr_loc(j-1)=gcorr_loc(j-1)
6705      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6706       endif
6707       do iii=1,2
6708         do kkk=1,5
6709           do lll=1,3
6710             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6711      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6712 cd            derx(lll,kkk,iii)=0.0d0
6713           enddo
6714         enddo
6715       enddo
6716 cd      gcorr_loc(l-1)=0.0d0
6717 cd      gcorr_loc(j-1)=0.0d0
6718 cd      gcorr_loc(k-1)=0.0d0
6719 cd      eel4=1.0d0
6720 cd      write (iout,*)'Contacts have occurred for peptide groups',
6721 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6722 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6723       if (j.lt.nres-1) then
6724         j1=j+1
6725         j2=j-1
6726       else
6727         j1=j-1
6728         j2=j-2
6729       endif
6730       if (l.lt.nres-1) then
6731         l1=l+1
6732         l2=l-1
6733       else
6734         l1=l-1
6735         l2=l-2
6736       endif
6737       do ll=1,3
6738 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6739         ggg1(ll)=eel4*g_contij(ll,1)
6740         ggg2(ll)=eel4*g_contij(ll,2)
6741         ghalf=0.5d0*ggg1(ll)
6742 cd        ghalf=0.0d0
6743         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6744         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6745         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6746         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6747 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6748         ghalf=0.5d0*ggg2(ll)
6749 cd        ghalf=0.0d0
6750         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6751         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6752         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6753         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6754       enddo
6755 cd      goto 1112
6756       do m=i+1,j-1
6757         do ll=1,3
6758 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6759           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6760         enddo
6761       enddo
6762       do m=k+1,l-1
6763         do ll=1,3
6764 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6765           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6766         enddo
6767       enddo
6768 1112  continue
6769       do m=i+2,j2
6770         do ll=1,3
6771           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6772         enddo
6773       enddo
6774       do m=k+2,l2
6775         do ll=1,3
6776           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6777         enddo
6778       enddo
6779 cd      do iii=1,nres-3
6780 cd        write (2,*) iii,gcorr_loc(iii)
6781 cd      enddo
6782       endif
6783       eello4=ekont*eel4
6784 cd      write (2,*) 'ekont',ekont
6785 cd      write (iout,*) 'eello4',ekont*eel4
6786       return
6787       end
6788 C---------------------------------------------------------------------------
6789       double precision function eello5(i,j,k,l,jj,kk)
6790       implicit real*8 (a-h,o-z)
6791       include 'DIMENSIONS'
6792       include 'DIMENSIONS.ZSCOPT'
6793       include 'COMMON.IOUNITS'
6794       include 'COMMON.CHAIN'
6795       include 'COMMON.DERIV'
6796       include 'COMMON.INTERACT'
6797       include 'COMMON.CONTACTS'
6798       include 'COMMON.TORSION'
6799       include 'COMMON.VAR'
6800       include 'COMMON.GEO'
6801       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6802       double precision ggg1(3),ggg2(3)
6803 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6804 C                                                                              C
6805 C                            Parallel chains                                   C
6806 C                                                                              C
6807 C          o             o                   o             o                   C
6808 C         /l\           / \             \   / \           / \   /              C
6809 C        /   \         /   \             \ /   \         /   \ /               C
6810 C       j| o |l1       | o |              o| o |         | o |o                C
6811 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6812 C      \i/   \         /   \ /             /   \         /   \                 C
6813 C       o    k1             o                                                  C
6814 C         (I)          (II)                (III)          (IV)                 C
6815 C                                                                              C
6816 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6817 C                                                                              C
6818 C                            Antiparallel chains                               C
6819 C                                                                              C
6820 C          o             o                   o             o                   C
6821 C         /j\           / \             \   / \           / \   /              C
6822 C        /   \         /   \             \ /   \         /   \ /               C
6823 C      j1| o |l        | o |              o| o |         | o |o                C
6824 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6825 C      \i/   \         /   \ /             /   \         /   \                 C
6826 C       o     k1            o                                                  C
6827 C         (I)          (II)                (III)          (IV)                 C
6828 C                                                                              C
6829 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6830 C                                                                              C
6831 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6832 C                                                                              C
6833 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6834 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6835 cd        eello5=0.0d0
6836 cd        return
6837 cd      endif
6838 cd      write (iout,*)
6839 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6840 cd     &   ' and',k,l
6841       itk=itortyp(itype(k))
6842       itl=itortyp(itype(l))
6843       itj=itortyp(itype(j))
6844       eello5_1=0.0d0
6845       eello5_2=0.0d0
6846       eello5_3=0.0d0
6847       eello5_4=0.0d0
6848 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6849 cd     &   eel5_3_num,eel5_4_num)
6850       do iii=1,2
6851         do kkk=1,5
6852           do lll=1,3
6853             derx(lll,kkk,iii)=0.0d0
6854           enddo
6855         enddo
6856       enddo
6857 cd      eij=facont_hb(jj,i)
6858 cd      ekl=facont_hb(kk,k)
6859 cd      ekont=eij*ekl
6860 cd      write (iout,*)'Contacts have occurred for peptide groups',
6861 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6862 cd      goto 1111
6863 C Contribution from the graph I.
6864 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6865 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6866       call transpose2(EUg(1,1,k),auxmat(1,1))
6867       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6868       vv(1)=pizda(1,1)-pizda(2,2)
6869       vv(2)=pizda(1,2)+pizda(2,1)
6870       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6871      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6872       if (calc_grad) then
6873 C Explicit gradient in virtual-dihedral angles.
6874       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6875      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6876      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6877       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6878       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6879       vv(1)=pizda(1,1)-pizda(2,2)
6880       vv(2)=pizda(1,2)+pizda(2,1)
6881       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6882      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6883      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6884       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6885       vv(1)=pizda(1,1)-pizda(2,2)
6886       vv(2)=pizda(1,2)+pizda(2,1)
6887       if (l.eq.j+1) then
6888         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6889      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6890      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6891       else
6892         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6893      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6894      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6895       endif
6896 C Cartesian gradient
6897       do iii=1,2
6898         do kkk=1,5
6899           do lll=1,3
6900             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6901      &        pizda(1,1))
6902             vv(1)=pizda(1,1)-pizda(2,2)
6903             vv(2)=pizda(1,2)+pizda(2,1)
6904             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6905      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6906      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6907           enddo
6908         enddo
6909       enddo
6910 c      goto 1112
6911       endif
6912 c1111  continue
6913 C Contribution from graph II
6914       call transpose2(EE(1,1,itk),auxmat(1,1))
6915       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6916       vv(1)=pizda(1,1)+pizda(2,2)
6917       vv(2)=pizda(2,1)-pizda(1,2)
6918       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6919      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6920       if (calc_grad) then
6921 C Explicit gradient in virtual-dihedral angles.
6922       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6923      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6924       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6925       vv(1)=pizda(1,1)+pizda(2,2)
6926       vv(2)=pizda(2,1)-pizda(1,2)
6927       if (l.eq.j+1) then
6928         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6929      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6930      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6931       else
6932         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6933      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6934      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6935       endif
6936 C Cartesian gradient
6937       do iii=1,2
6938         do kkk=1,5
6939           do lll=1,3
6940             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6941      &        pizda(1,1))
6942             vv(1)=pizda(1,1)+pizda(2,2)
6943             vv(2)=pizda(2,1)-pizda(1,2)
6944             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6945      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6946      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6947           enddo
6948         enddo
6949       enddo
6950 cd      goto 1112
6951       endif
6952 cd1111  continue
6953       if (l.eq.j+1) then
6954 cd        goto 1110
6955 C Parallel orientation
6956 C Contribution from graph III
6957         call transpose2(EUg(1,1,l),auxmat(1,1))
6958         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6959         vv(1)=pizda(1,1)-pizda(2,2)
6960         vv(2)=pizda(1,2)+pizda(2,1)
6961         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6962      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6963         if (calc_grad) then
6964 C Explicit gradient in virtual-dihedral angles.
6965         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6966      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6967      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6968         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6969         vv(1)=pizda(1,1)-pizda(2,2)
6970         vv(2)=pizda(1,2)+pizda(2,1)
6971         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6972      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6973      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6974         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6975         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6976         vv(1)=pizda(1,1)-pizda(2,2)
6977         vv(2)=pizda(1,2)+pizda(2,1)
6978         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6979      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6980      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6981 C Cartesian gradient
6982         do iii=1,2
6983           do kkk=1,5
6984             do lll=1,3
6985               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6986      &          pizda(1,1))
6987               vv(1)=pizda(1,1)-pizda(2,2)
6988               vv(2)=pizda(1,2)+pizda(2,1)
6989               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6990      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6991      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6992             enddo
6993           enddo
6994         enddo
6995 cd        goto 1112
6996         endif
6997 C Contribution from graph IV
6998 cd1110    continue
6999         call transpose2(EE(1,1,itl),auxmat(1,1))
7000         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7001         vv(1)=pizda(1,1)+pizda(2,2)
7002         vv(2)=pizda(2,1)-pizda(1,2)
7003         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7004      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7005         if (calc_grad) then
7006 C Explicit gradient in virtual-dihedral angles.
7007         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7008      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7009         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7010         vv(1)=pizda(1,1)+pizda(2,2)
7011         vv(2)=pizda(2,1)-pizda(1,2)
7012         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7013      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7014      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7015 C Cartesian gradient
7016         do iii=1,2
7017           do kkk=1,5
7018             do lll=1,3
7019               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7020      &          pizda(1,1))
7021               vv(1)=pizda(1,1)+pizda(2,2)
7022               vv(2)=pizda(2,1)-pizda(1,2)
7023               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7024      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7025      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7026             enddo
7027           enddo
7028         enddo
7029         endif
7030       else
7031 C Antiparallel orientation
7032 C Contribution from graph III
7033 c        goto 1110
7034         call transpose2(EUg(1,1,j),auxmat(1,1))
7035         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7036         vv(1)=pizda(1,1)-pizda(2,2)
7037         vv(2)=pizda(1,2)+pizda(2,1)
7038         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7039      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7040         if (calc_grad) then
7041 C Explicit gradient in virtual-dihedral angles.
7042         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7043      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7044      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7045         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7046         vv(1)=pizda(1,1)-pizda(2,2)
7047         vv(2)=pizda(1,2)+pizda(2,1)
7048         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7049      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7050      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7051         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7052         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7053         vv(1)=pizda(1,1)-pizda(2,2)
7054         vv(2)=pizda(1,2)+pizda(2,1)
7055         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7056      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7057      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7058 C Cartesian gradient
7059         do iii=1,2
7060           do kkk=1,5
7061             do lll=1,3
7062               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7063      &          pizda(1,1))
7064               vv(1)=pizda(1,1)-pizda(2,2)
7065               vv(2)=pizda(1,2)+pizda(2,1)
7066               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7067      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7068      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7069             enddo
7070           enddo
7071         enddo
7072 cd        goto 1112
7073         endif
7074 C Contribution from graph IV
7075 1110    continue
7076         call transpose2(EE(1,1,itj),auxmat(1,1))
7077         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7078         vv(1)=pizda(1,1)+pizda(2,2)
7079         vv(2)=pizda(2,1)-pizda(1,2)
7080         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7081      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7082         if (calc_grad) then
7083 C Explicit gradient in virtual-dihedral angles.
7084         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7085      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7086         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7087         vv(1)=pizda(1,1)+pizda(2,2)
7088         vv(2)=pizda(2,1)-pizda(1,2)
7089         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7090      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7091      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7092 C Cartesian gradient
7093         do iii=1,2
7094           do kkk=1,5
7095             do lll=1,3
7096               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7097      &          pizda(1,1))
7098               vv(1)=pizda(1,1)+pizda(2,2)
7099               vv(2)=pizda(2,1)-pizda(1,2)
7100               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7101      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7102      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7103             enddo
7104           enddo
7105         enddo
7106       endif
7107       endif
7108 1112  continue
7109       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7110 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7111 cd        write (2,*) 'ijkl',i,j,k,l
7112 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7113 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7114 cd      endif
7115 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7116 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7117 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7118 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7119       if (calc_grad) then
7120       if (j.lt.nres-1) then
7121         j1=j+1
7122         j2=j-1
7123       else
7124         j1=j-1
7125         j2=j-2
7126       endif
7127       if (l.lt.nres-1) then
7128         l1=l+1
7129         l2=l-1
7130       else
7131         l1=l-1
7132         l2=l-2
7133       endif
7134 cd      eij=1.0d0
7135 cd      ekl=1.0d0
7136 cd      ekont=1.0d0
7137 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7138       do ll=1,3
7139         ggg1(ll)=eel5*g_contij(ll,1)
7140         ggg2(ll)=eel5*g_contij(ll,2)
7141 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7142         ghalf=0.5d0*ggg1(ll)
7143 cd        ghalf=0.0d0
7144         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7145         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7146         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7147         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7148 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7149         ghalf=0.5d0*ggg2(ll)
7150 cd        ghalf=0.0d0
7151         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7152         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7153         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7154         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7155       enddo
7156 cd      goto 1112
7157       do m=i+1,j-1
7158         do ll=1,3
7159 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7160           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7161         enddo
7162       enddo
7163       do m=k+1,l-1
7164         do ll=1,3
7165 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7166           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7167         enddo
7168       enddo
7169 c1112  continue
7170       do m=i+2,j2
7171         do ll=1,3
7172           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7173         enddo
7174       enddo
7175       do m=k+2,l2
7176         do ll=1,3
7177           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7178         enddo
7179       enddo
7180 cd      do iii=1,nres-3
7181 cd        write (2,*) iii,g_corr5_loc(iii)
7182 cd      enddo
7183       endif
7184       eello5=ekont*eel5
7185 cd      write (2,*) 'ekont',ekont
7186 cd      write (iout,*) 'eello5',ekont*eel5
7187       return
7188       end
7189 c--------------------------------------------------------------------------
7190       double precision function eello6(i,j,k,l,jj,kk)
7191       implicit real*8 (a-h,o-z)
7192       include 'DIMENSIONS'
7193       include 'DIMENSIONS.ZSCOPT'
7194       include 'COMMON.IOUNITS'
7195       include 'COMMON.CHAIN'
7196       include 'COMMON.DERIV'
7197       include 'COMMON.INTERACT'
7198       include 'COMMON.CONTACTS'
7199       include 'COMMON.TORSION'
7200       include 'COMMON.VAR'
7201       include 'COMMON.GEO'
7202       include 'COMMON.FFIELD'
7203       double precision ggg1(3),ggg2(3)
7204 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7205 cd        eello6=0.0d0
7206 cd        return
7207 cd      endif
7208 cd      write (iout,*)
7209 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7210 cd     &   ' and',k,l
7211       eello6_1=0.0d0
7212       eello6_2=0.0d0
7213       eello6_3=0.0d0
7214       eello6_4=0.0d0
7215       eello6_5=0.0d0
7216       eello6_6=0.0d0
7217 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7218 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7219       do iii=1,2
7220         do kkk=1,5
7221           do lll=1,3
7222             derx(lll,kkk,iii)=0.0d0
7223           enddo
7224         enddo
7225       enddo
7226 cd      eij=facont_hb(jj,i)
7227 cd      ekl=facont_hb(kk,k)
7228 cd      ekont=eij*ekl
7229 cd      eij=1.0d0
7230 cd      ekl=1.0d0
7231 cd      ekont=1.0d0
7232       if (l.eq.j+1) then
7233         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7234         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7235         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7236         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7237         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7238         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7239       else
7240         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7241         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7242         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7243         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7244         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7245           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7246         else
7247           eello6_5=0.0d0
7248         endif
7249         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7250       endif
7251 C If turn contributions are considered, they will be handled separately.
7252       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7253 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7254 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7255 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7256 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7257 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7258 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7259 cd      goto 1112
7260       if (calc_grad) then
7261       if (j.lt.nres-1) then
7262         j1=j+1
7263         j2=j-1
7264       else
7265         j1=j-1
7266         j2=j-2
7267       endif
7268       if (l.lt.nres-1) then
7269         l1=l+1
7270         l2=l-1
7271       else
7272         l1=l-1
7273         l2=l-2
7274       endif
7275       do ll=1,3
7276         ggg1(ll)=eel6*g_contij(ll,1)
7277         ggg2(ll)=eel6*g_contij(ll,2)
7278 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7279         ghalf=0.5d0*ggg1(ll)
7280 cd        ghalf=0.0d0
7281         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7282         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7283         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7284         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7285         ghalf=0.5d0*ggg2(ll)
7286 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7287 cd        ghalf=0.0d0
7288         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7289         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7290         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7291         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7292       enddo
7293 cd      goto 1112
7294       do m=i+1,j-1
7295         do ll=1,3
7296 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7297           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7298         enddo
7299       enddo
7300       do m=k+1,l-1
7301         do ll=1,3
7302 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7303           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7304         enddo
7305       enddo
7306 1112  continue
7307       do m=i+2,j2
7308         do ll=1,3
7309           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7310         enddo
7311       enddo
7312       do m=k+2,l2
7313         do ll=1,3
7314           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7315         enddo
7316       enddo
7317 cd      do iii=1,nres-3
7318 cd        write (2,*) iii,g_corr6_loc(iii)
7319 cd      enddo
7320       endif
7321       eello6=ekont*eel6
7322 cd      write (2,*) 'ekont',ekont
7323 cd      write (iout,*) 'eello6',ekont*eel6
7324       return
7325       end
7326 c--------------------------------------------------------------------------
7327       double precision function eello6_graph1(i,j,k,l,imat,swap)
7328       implicit real*8 (a-h,o-z)
7329       include 'DIMENSIONS'
7330       include 'DIMENSIONS.ZSCOPT'
7331       include 'COMMON.IOUNITS'
7332       include 'COMMON.CHAIN'
7333       include 'COMMON.DERIV'
7334       include 'COMMON.INTERACT'
7335       include 'COMMON.CONTACTS'
7336       include 'COMMON.TORSION'
7337       include 'COMMON.VAR'
7338       include 'COMMON.GEO'
7339       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7340       logical swap
7341       logical lprn
7342       common /kutas/ lprn
7343 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7344 C                                                                              C
7345 C      Parallel       Antiparallel                                             C
7346 C                                                                              C
7347 C          o             o                                                     C
7348 C         /l\           /j\                                                    C
7349 C        /   \         /   \                                                   C
7350 C       /| o |         | o |\                                                  C
7351 C     \ j|/k\|  /   \  |/k\|l /                                                C
7352 C      \ /   \ /     \ /   \ /                                                 C
7353 C       o     o       o     o                                                  C
7354 C       i             i                                                        C
7355 C                                                                              C
7356 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7357       itk=itortyp(itype(k))
7358       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7359       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7360       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7361       call transpose2(EUgC(1,1,k),auxmat(1,1))
7362       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7363       vv1(1)=pizda1(1,1)-pizda1(2,2)
7364       vv1(2)=pizda1(1,2)+pizda1(2,1)
7365       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7366       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7367       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7368       s5=scalar2(vv(1),Dtobr2(1,i))
7369 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7370       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7371       if (.not. calc_grad) return
7372       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7373      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7374      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7375      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7376      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7377      & +scalar2(vv(1),Dtobr2der(1,i)))
7378       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7379       vv1(1)=pizda1(1,1)-pizda1(2,2)
7380       vv1(2)=pizda1(1,2)+pizda1(2,1)
7381       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7382       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7383       if (l.eq.j+1) then
7384         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7385      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7386      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7387      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7388      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7389       else
7390         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7391      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7392      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7393      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7394      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7395       endif
7396       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7397       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7398       vv1(1)=pizda1(1,1)-pizda1(2,2)
7399       vv1(2)=pizda1(1,2)+pizda1(2,1)
7400       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7401      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7402      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7403      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7404       do iii=1,2
7405         if (swap) then
7406           ind=3-iii
7407         else
7408           ind=iii
7409         endif
7410         do kkk=1,5
7411           do lll=1,3
7412             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7413             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7414             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7415             call transpose2(EUgC(1,1,k),auxmat(1,1))
7416             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7417      &        pizda1(1,1))
7418             vv1(1)=pizda1(1,1)-pizda1(2,2)
7419             vv1(2)=pizda1(1,2)+pizda1(2,1)
7420             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7421             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7422      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7423             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7424      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7425             s5=scalar2(vv(1),Dtobr2(1,i))
7426             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7427           enddo
7428         enddo
7429       enddo
7430       return
7431       end
7432 c----------------------------------------------------------------------------
7433       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7434       implicit real*8 (a-h,o-z)
7435       include 'DIMENSIONS'
7436       include 'DIMENSIONS.ZSCOPT'
7437       include 'COMMON.IOUNITS'
7438       include 'COMMON.CHAIN'
7439       include 'COMMON.DERIV'
7440       include 'COMMON.INTERACT'
7441       include 'COMMON.CONTACTS'
7442       include 'COMMON.TORSION'
7443       include 'COMMON.VAR'
7444       include 'COMMON.GEO'
7445       logical swap
7446       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7447      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7448       logical lprn
7449       common /kutas/ lprn
7450 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7451 C                                                                              C
7452 C      Parallel       Antiparallel                                             C
7453 C                                                                              C
7454 C          o             o                                                     C
7455 C     \   /l\           /j\   /                                                C
7456 C      \ /   \         /   \ /                                                 C
7457 C       o| o |         | o |o                                                  C
7458 C     \ j|/k\|      \  |/k\|l                                                  C
7459 C      \ /   \       \ /   \                                                   C
7460 C       o             o                                                        C
7461 C       i             i                                                        C
7462 C                                                                              C
7463 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7464 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7465 C AL 7/4/01 s1 would occur in the sixth-order moment,
7466 C           but not in a cluster cumulant
7467 #ifdef MOMENT
7468       s1=dip(1,jj,i)*dip(1,kk,k)
7469 #endif
7470       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7471       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7472       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7473       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7474       call transpose2(EUg(1,1,k),auxmat(1,1))
7475       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7476       vv(1)=pizda(1,1)-pizda(2,2)
7477       vv(2)=pizda(1,2)+pizda(2,1)
7478       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7479 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7480 #ifdef MOMENT
7481       eello6_graph2=-(s1+s2+s3+s4)
7482 #else
7483       eello6_graph2=-(s2+s3+s4)
7484 #endif
7485 c      eello6_graph2=-s3
7486       if (.not. calc_grad) return
7487 C Derivatives in gamma(i-1)
7488       if (i.gt.1) then
7489 #ifdef MOMENT
7490         s1=dipderg(1,jj,i)*dip(1,kk,k)
7491 #endif
7492         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7493         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7494         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7495         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7496 #ifdef MOMENT
7497         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7498 #else
7499         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7500 #endif
7501 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7502       endif
7503 C Derivatives in gamma(k-1)
7504 #ifdef MOMENT
7505       s1=dip(1,jj,i)*dipderg(1,kk,k)
7506 #endif
7507       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7508       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7509       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7510       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7511       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7512       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7513       vv(1)=pizda(1,1)-pizda(2,2)
7514       vv(2)=pizda(1,2)+pizda(2,1)
7515       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7516 #ifdef MOMENT
7517       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7518 #else
7519       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7520 #endif
7521 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7522 C Derivatives in gamma(j-1) or gamma(l-1)
7523       if (j.gt.1) then
7524 #ifdef MOMENT
7525         s1=dipderg(3,jj,i)*dip(1,kk,k)
7526 #endif
7527         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7528         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7529         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7530         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7531         vv(1)=pizda(1,1)-pizda(2,2)
7532         vv(2)=pizda(1,2)+pizda(2,1)
7533         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7534 #ifdef MOMENT
7535         if (swap) then
7536           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7537         else
7538           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7539         endif
7540 #endif
7541         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7542 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7543       endif
7544 C Derivatives in gamma(l-1) or gamma(j-1)
7545       if (l.gt.1) then
7546 #ifdef MOMENT
7547         s1=dip(1,jj,i)*dipderg(3,kk,k)
7548 #endif
7549         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7550         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7551         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7552         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7553         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7554         vv(1)=pizda(1,1)-pizda(2,2)
7555         vv(2)=pizda(1,2)+pizda(2,1)
7556         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7557 #ifdef MOMENT
7558         if (swap) then
7559           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7560         else
7561           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7562         endif
7563 #endif
7564         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7565 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7566       endif
7567 C Cartesian derivatives.
7568       if (lprn) then
7569         write (2,*) 'In eello6_graph2'
7570         do iii=1,2
7571           write (2,*) 'iii=',iii
7572           do kkk=1,5
7573             write (2,*) 'kkk=',kkk
7574             do jjj=1,2
7575               write (2,'(3(2f10.5),5x)')
7576      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7577             enddo
7578           enddo
7579         enddo
7580       endif
7581       do iii=1,2
7582         do kkk=1,5
7583           do lll=1,3
7584 #ifdef MOMENT
7585             if (iii.eq.1) then
7586               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7587             else
7588               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7589             endif
7590 #endif
7591             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7592      &        auxvec(1))
7593             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7594             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7595      &        auxvec(1))
7596             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7597             call transpose2(EUg(1,1,k),auxmat(1,1))
7598             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7599      &        pizda(1,1))
7600             vv(1)=pizda(1,1)-pizda(2,2)
7601             vv(2)=pizda(1,2)+pizda(2,1)
7602             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7603 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7604 #ifdef MOMENT
7605             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7606 #else
7607             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7608 #endif
7609             if (swap) then
7610               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7611             else
7612               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7613             endif
7614           enddo
7615         enddo
7616       enddo
7617       return
7618       end
7619 c----------------------------------------------------------------------------
7620       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7621       implicit real*8 (a-h,o-z)
7622       include 'DIMENSIONS'
7623       include 'DIMENSIONS.ZSCOPT'
7624       include 'COMMON.IOUNITS'
7625       include 'COMMON.CHAIN'
7626       include 'COMMON.DERIV'
7627       include 'COMMON.INTERACT'
7628       include 'COMMON.CONTACTS'
7629       include 'COMMON.TORSION'
7630       include 'COMMON.VAR'
7631       include 'COMMON.GEO'
7632       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7633       logical swap
7634 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7635 C                                                                              C
7636 C      Parallel       Antiparallel                                             C
7637 C                                                                              C
7638 C          o             o                                                     C
7639 C         /l\   /   \   /j\                                                    C
7640 C        /   \ /     \ /   \                                                   C
7641 C       /| o |o       o| o |\                                                  C
7642 C       j|/k\|  /      |/k\|l /                                                C
7643 C        /   \ /       /   \ /                                                 C
7644 C       /     o       /     o                                                  C
7645 C       i             i                                                        C
7646 C                                                                              C
7647 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7648 C
7649 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7650 C           energy moment and not to the cluster cumulant.
7651       iti=itortyp(itype(i))
7652       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7653         itj1=itortyp(itype(j+1))
7654       else
7655         itj1=ntortyp+1
7656       endif
7657       itk=itortyp(itype(k))
7658       itk1=itortyp(itype(k+1))
7659       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7660         itl1=itortyp(itype(l+1))
7661       else
7662         itl1=ntortyp+1
7663       endif
7664 #ifdef MOMENT
7665       s1=dip(4,jj,i)*dip(4,kk,k)
7666 #endif
7667       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7668       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7669       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7670       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7671       call transpose2(EE(1,1,itk),auxmat(1,1))
7672       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7673       vv(1)=pizda(1,1)+pizda(2,2)
7674       vv(2)=pizda(2,1)-pizda(1,2)
7675       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7676 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7677 #ifdef MOMENT
7678       eello6_graph3=-(s1+s2+s3+s4)
7679 #else
7680       eello6_graph3=-(s2+s3+s4)
7681 #endif
7682 c      eello6_graph3=-s4
7683       if (.not. calc_grad) return
7684 C Derivatives in gamma(k-1)
7685       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7686       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7687       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7688       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7689 C Derivatives in gamma(l-1)
7690       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7691       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7692       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7693       vv(1)=pizda(1,1)+pizda(2,2)
7694       vv(2)=pizda(2,1)-pizda(1,2)
7695       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7696       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7697 C Cartesian derivatives.
7698       do iii=1,2
7699         do kkk=1,5
7700           do lll=1,3
7701 #ifdef MOMENT
7702             if (iii.eq.1) then
7703               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7704             else
7705               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7706             endif
7707 #endif
7708             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7709      &        auxvec(1))
7710             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7711             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7712      &        auxvec(1))
7713             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7714             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7715      &        pizda(1,1))
7716             vv(1)=pizda(1,1)+pizda(2,2)
7717             vv(2)=pizda(2,1)-pizda(1,2)
7718             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7719 #ifdef MOMENT
7720             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7721 #else
7722             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7723 #endif
7724             if (swap) then
7725               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7726             else
7727               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7728             endif
7729 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7730           enddo
7731         enddo
7732       enddo
7733       return
7734       end
7735 c----------------------------------------------------------------------------
7736       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7737       implicit real*8 (a-h,o-z)
7738       include 'DIMENSIONS'
7739       include 'DIMENSIONS.ZSCOPT'
7740       include 'COMMON.IOUNITS'
7741       include 'COMMON.CHAIN'
7742       include 'COMMON.DERIV'
7743       include 'COMMON.INTERACT'
7744       include 'COMMON.CONTACTS'
7745       include 'COMMON.TORSION'
7746       include 'COMMON.VAR'
7747       include 'COMMON.GEO'
7748       include 'COMMON.FFIELD'
7749       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7750      & auxvec1(2),auxmat1(2,2)
7751       logical swap
7752 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7753 C                                                                              C
7754 C      Parallel       Antiparallel                                             C
7755 C                                                                              C
7756 C          o             o                                                     C
7757 C         /l\   /   \   /j\                                                    C
7758 C        /   \ /     \ /   \                                                   C
7759 C       /| o |o       o| o |\                                                  C
7760 C     \ j|/k\|      \  |/k\|l                                                  C
7761 C      \ /   \       \ /   \                                                   C
7762 C       o     \       o     \                                                  C
7763 C       i             i                                                        C
7764 C                                                                              C
7765 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7766 C
7767 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7768 C           energy moment and not to the cluster cumulant.
7769 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7770       iti=itortyp(itype(i))
7771       itj=itortyp(itype(j))
7772       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7773         itj1=itortyp(itype(j+1))
7774       else
7775         itj1=ntortyp+1
7776       endif
7777       itk=itortyp(itype(k))
7778       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7779         itk1=itortyp(itype(k+1))
7780       else
7781         itk1=ntortyp+1
7782       endif
7783       itl=itortyp(itype(l))
7784       if (l.lt.nres-1) then
7785         itl1=itortyp(itype(l+1))
7786       else
7787         itl1=ntortyp+1
7788       endif
7789 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7790 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7791 cd     & ' itl',itl,' itl1',itl1
7792 #ifdef MOMENT
7793       if (imat.eq.1) then
7794         s1=dip(3,jj,i)*dip(3,kk,k)
7795       else
7796         s1=dip(2,jj,j)*dip(2,kk,l)
7797       endif
7798 #endif
7799       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7800       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7801       if (j.eq.l+1) then
7802         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7803         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7804       else
7805         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7806         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7807       endif
7808       call transpose2(EUg(1,1,k),auxmat(1,1))
7809       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7810       vv(1)=pizda(1,1)-pizda(2,2)
7811       vv(2)=pizda(2,1)+pizda(1,2)
7812       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7813 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7814 #ifdef MOMENT
7815       eello6_graph4=-(s1+s2+s3+s4)
7816 #else
7817       eello6_graph4=-(s2+s3+s4)
7818 #endif
7819       if (.not. calc_grad) return
7820 C Derivatives in gamma(i-1)
7821       if (i.gt.1) then
7822 #ifdef MOMENT
7823         if (imat.eq.1) then
7824           s1=dipderg(2,jj,i)*dip(3,kk,k)
7825         else
7826           s1=dipderg(4,jj,j)*dip(2,kk,l)
7827         endif
7828 #endif
7829         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7830         if (j.eq.l+1) then
7831           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7832           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7833         else
7834           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7835           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7836         endif
7837         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7838         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7839 cd          write (2,*) 'turn6 derivatives'
7840 #ifdef MOMENT
7841           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7842 #else
7843           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7844 #endif
7845         else
7846 #ifdef MOMENT
7847           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7848 #else
7849           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7850 #endif
7851         endif
7852       endif
7853 C Derivatives in gamma(k-1)
7854 #ifdef MOMENT
7855       if (imat.eq.1) then
7856         s1=dip(3,jj,i)*dipderg(2,kk,k)
7857       else
7858         s1=dip(2,jj,j)*dipderg(4,kk,l)
7859       endif
7860 #endif
7861       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7862       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7863       if (j.eq.l+1) then
7864         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7865         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7866       else
7867         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7868         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7869       endif
7870       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7871       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7872       vv(1)=pizda(1,1)-pizda(2,2)
7873       vv(2)=pizda(2,1)+pizda(1,2)
7874       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7875       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7876 #ifdef MOMENT
7877         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7878 #else
7879         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7880 #endif
7881       else
7882 #ifdef MOMENT
7883         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7884 #else
7885         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7886 #endif
7887       endif
7888 C Derivatives in gamma(j-1) or gamma(l-1)
7889       if (l.eq.j+1 .and. l.gt.1) then
7890         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7891         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7892         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7893         vv(1)=pizda(1,1)-pizda(2,2)
7894         vv(2)=pizda(2,1)+pizda(1,2)
7895         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7896         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7897       else if (j.gt.1) then
7898         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7899         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7900         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7901         vv(1)=pizda(1,1)-pizda(2,2)
7902         vv(2)=pizda(2,1)+pizda(1,2)
7903         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7904         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7905           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7906         else
7907           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7908         endif
7909       endif
7910 C Cartesian derivatives.
7911       do iii=1,2
7912         do kkk=1,5
7913           do lll=1,3
7914 #ifdef MOMENT
7915             if (iii.eq.1) then
7916               if (imat.eq.1) then
7917                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7918               else
7919                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7920               endif
7921             else
7922               if (imat.eq.1) then
7923                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7924               else
7925                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7926               endif
7927             endif
7928 #endif
7929             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7930      &        auxvec(1))
7931             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7932             if (j.eq.l+1) then
7933               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7934      &          b1(1,itj1),auxvec(1))
7935               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7936             else
7937               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7938      &          b1(1,itl1),auxvec(1))
7939               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7940             endif
7941             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7942      &        pizda(1,1))
7943             vv(1)=pizda(1,1)-pizda(2,2)
7944             vv(2)=pizda(2,1)+pizda(1,2)
7945             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7946             if (swap) then
7947               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7948 #ifdef MOMENT
7949                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7950      &             -(s1+s2+s4)
7951 #else
7952                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7953      &             -(s2+s4)
7954 #endif
7955                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7956               else
7957 #ifdef MOMENT
7958                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7959 #else
7960                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7961 #endif
7962                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7963               endif
7964             else
7965 #ifdef MOMENT
7966               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7967 #else
7968               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7969 #endif
7970               if (l.eq.j+1) then
7971                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7972               else
7973                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7974               endif
7975             endif
7976           enddo
7977         enddo
7978       enddo
7979       return
7980       end
7981 c----------------------------------------------------------------------------
7982       double precision function eello_turn6(i,jj,kk)
7983       implicit real*8 (a-h,o-z)
7984       include 'DIMENSIONS'
7985       include 'DIMENSIONS.ZSCOPT'
7986       include 'COMMON.IOUNITS'
7987       include 'COMMON.CHAIN'
7988       include 'COMMON.DERIV'
7989       include 'COMMON.INTERACT'
7990       include 'COMMON.CONTACTS'
7991       include 'COMMON.TORSION'
7992       include 'COMMON.VAR'
7993       include 'COMMON.GEO'
7994       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7995      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7996      &  ggg1(3),ggg2(3)
7997       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7998      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7999 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8000 C           the respective energy moment and not to the cluster cumulant.
8001       eello_turn6=0.0d0
8002       j=i+4
8003       k=i+1
8004       l=i+3
8005       iti=itortyp(itype(i))
8006       itk=itortyp(itype(k))
8007       itk1=itortyp(itype(k+1))
8008       itl=itortyp(itype(l))
8009       itj=itortyp(itype(j))
8010 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8011 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8012 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8013 cd        eello6=0.0d0
8014 cd        return
8015 cd      endif
8016 cd      write (iout,*)
8017 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8018 cd     &   ' and',k,l
8019 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8020       do iii=1,2
8021         do kkk=1,5
8022           do lll=1,3
8023             derx_turn(lll,kkk,iii)=0.0d0
8024           enddo
8025         enddo
8026       enddo
8027 cd      eij=1.0d0
8028 cd      ekl=1.0d0
8029 cd      ekont=1.0d0
8030       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8031 cd      eello6_5=0.0d0
8032 cd      write (2,*) 'eello6_5',eello6_5
8033 #ifdef MOMENT
8034       call transpose2(AEA(1,1,1),auxmat(1,1))
8035       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8036       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8037       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8038 #else
8039       s1 = 0.0d0
8040 #endif
8041       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8042       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8043       s2 = scalar2(b1(1,itk),vtemp1(1))
8044 #ifdef MOMENT
8045       call transpose2(AEA(1,1,2),atemp(1,1))
8046       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8047       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8048       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8049 #else
8050       s8=0.0d0
8051 #endif
8052       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8053       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8054       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8055 #ifdef MOMENT
8056       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8057       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8058       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8059       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8060       ss13 = scalar2(b1(1,itk),vtemp4(1))
8061       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8062 #else
8063       s13=0.0d0
8064 #endif
8065 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8066 c      s1=0.0d0
8067 c      s2=0.0d0
8068 c      s8=0.0d0
8069 c      s12=0.0d0
8070 c      s13=0.0d0
8071       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8072       if (calc_grad) then
8073 C Derivatives in gamma(i+2)
8074 #ifdef MOMENT
8075       call transpose2(AEA(1,1,1),auxmatd(1,1))
8076       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8077       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8078       call transpose2(AEAderg(1,1,2),atempd(1,1))
8079       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8080       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8081 #else
8082       s8d=0.0d0
8083 #endif
8084       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8085       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8086       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8087 c      s1d=0.0d0
8088 c      s2d=0.0d0
8089 c      s8d=0.0d0
8090 c      s12d=0.0d0
8091 c      s13d=0.0d0
8092       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8093 C Derivatives in gamma(i+3)
8094 #ifdef MOMENT
8095       call transpose2(AEA(1,1,1),auxmatd(1,1))
8096       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8097       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8098       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8099 #else
8100       s1d=0.0d0
8101 #endif
8102       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8103       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8104       s2d = scalar2(b1(1,itk),vtemp1d(1))
8105 #ifdef MOMENT
8106       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8107       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8108 #endif
8109       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8110 #ifdef MOMENT
8111       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8112       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8113       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8114 #else
8115       s13d=0.0d0
8116 #endif
8117 c      s1d=0.0d0
8118 c      s2d=0.0d0
8119 c      s8d=0.0d0
8120 c      s12d=0.0d0
8121 c      s13d=0.0d0
8122 #ifdef MOMENT
8123       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8124      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8125 #else
8126       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8127      &               -0.5d0*ekont*(s2d+s12d)
8128 #endif
8129 C Derivatives in gamma(i+4)
8130       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8131       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8132       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8133 #ifdef MOMENT
8134       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8135       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8136       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8137 #else
8138       s13d = 0.0d0
8139 #endif
8140 c      s1d=0.0d0
8141 c      s2d=0.0d0
8142 c      s8d=0.0d0
8143 C      s12d=0.0d0
8144 c      s13d=0.0d0
8145 #ifdef MOMENT
8146       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8147 #else
8148       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8149 #endif
8150 C Derivatives in gamma(i+5)
8151 #ifdef MOMENT
8152       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8153       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8154       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8155 #else
8156       s1d = 0.0d0
8157 #endif
8158       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8159       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8160       s2d = scalar2(b1(1,itk),vtemp1d(1))
8161 #ifdef MOMENT
8162       call transpose2(AEA(1,1,2),atempd(1,1))
8163       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8164       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8165 #else
8166       s8d = 0.0d0
8167 #endif
8168       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8169       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8170 #ifdef MOMENT
8171       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8172       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8173       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8174 #else
8175       s13d = 0.0d0
8176 #endif
8177 c      s1d=0.0d0
8178 c      s2d=0.0d0
8179 c      s8d=0.0d0
8180 c      s12d=0.0d0
8181 c      s13d=0.0d0
8182 #ifdef MOMENT
8183       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8184      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8185 #else
8186       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8187      &               -0.5d0*ekont*(s2d+s12d)
8188 #endif
8189 C Cartesian derivatives
8190       do iii=1,2
8191         do kkk=1,5
8192           do lll=1,3
8193 #ifdef MOMENT
8194             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8195             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8196             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8197 #else
8198             s1d = 0.0d0
8199 #endif
8200             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8201             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8202      &          vtemp1d(1))
8203             s2d = scalar2(b1(1,itk),vtemp1d(1))
8204 #ifdef MOMENT
8205             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8206             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8207             s8d = -(atempd(1,1)+atempd(2,2))*
8208      &           scalar2(cc(1,1,itl),vtemp2(1))
8209 #else
8210             s8d = 0.0d0
8211 #endif
8212             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8213      &           auxmatd(1,1))
8214             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8215             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8216 c      s1d=0.0d0
8217 c      s2d=0.0d0
8218 c      s8d=0.0d0
8219 c      s12d=0.0d0
8220 c      s13d=0.0d0
8221 #ifdef MOMENT
8222             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8223      &        - 0.5d0*(s1d+s2d)
8224 #else
8225             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8226      &        - 0.5d0*s2d
8227 #endif
8228 #ifdef MOMENT
8229             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8230      &        - 0.5d0*(s8d+s12d)
8231 #else
8232             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8233      &        - 0.5d0*s12d
8234 #endif
8235           enddo
8236         enddo
8237       enddo
8238 #ifdef MOMENT
8239       do kkk=1,5
8240         do lll=1,3
8241           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8242      &      achuj_tempd(1,1))
8243           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8244           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8245           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8246           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8247           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8248      &      vtemp4d(1))
8249           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8250           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8251           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8252         enddo
8253       enddo
8254 #endif
8255 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8256 cd     &  16*eel_turn6_num
8257 cd      goto 1112
8258       if (j.lt.nres-1) then
8259         j1=j+1
8260         j2=j-1
8261       else
8262         j1=j-1
8263         j2=j-2
8264       endif
8265       if (l.lt.nres-1) then
8266         l1=l+1
8267         l2=l-1
8268       else
8269         l1=l-1
8270         l2=l-2
8271       endif
8272       do ll=1,3
8273         ggg1(ll)=eel_turn6*g_contij(ll,1)
8274         ggg2(ll)=eel_turn6*g_contij(ll,2)
8275         ghalf=0.5d0*ggg1(ll)
8276 cd        ghalf=0.0d0
8277         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8278      &    +ekont*derx_turn(ll,2,1)
8279         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8280         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8281      &    +ekont*derx_turn(ll,4,1)
8282         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8283         ghalf=0.5d0*ggg2(ll)
8284 cd        ghalf=0.0d0
8285         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8286      &    +ekont*derx_turn(ll,2,2)
8287         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8288         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8289      &    +ekont*derx_turn(ll,4,2)
8290         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8291       enddo
8292 cd      goto 1112
8293       do m=i+1,j-1
8294         do ll=1,3
8295           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8296         enddo
8297       enddo
8298       do m=k+1,l-1
8299         do ll=1,3
8300           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8301         enddo
8302       enddo
8303 1112  continue
8304       do m=i+2,j2
8305         do ll=1,3
8306           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8307         enddo
8308       enddo
8309       do m=k+2,l2
8310         do ll=1,3
8311           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8312         enddo
8313       enddo
8314 cd      do iii=1,nres-3
8315 cd        write (2,*) iii,g_corr6_loc(iii)
8316 cd      enddo
8317       endif
8318       eello_turn6=ekont*eel_turn6
8319 cd      write (2,*) 'ekont',ekont
8320 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8321       return
8322       end
8323 crc-------------------------------------------------
8324 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8325       subroutine Eliptransfer(eliptran)
8326       implicit real*8 (a-h,o-z)
8327       include 'DIMENSIONS'
8328       include 'COMMON.GEO'
8329       include 'COMMON.VAR'
8330       include 'COMMON.LOCAL'
8331       include 'COMMON.CHAIN'
8332       include 'COMMON.DERIV'
8333       include 'COMMON.INTERACT'
8334       include 'COMMON.IOUNITS'
8335       include 'COMMON.CALC'
8336       include 'COMMON.CONTROL'
8337       include 'COMMON.SPLITELE'
8338       include 'COMMON.SBRIDGE'
8339 C this is done by Adasko
8340 C      print *,"wchodze"
8341 C structure of box:
8342 C      water
8343 C--bordliptop-- buffore starts
8344 C--bufliptop--- here true lipid starts
8345 C      lipid
8346 C--buflipbot--- lipid ends buffore starts
8347 C--bordlipbot--buffore ends
8348       eliptran=0.0
8349       do i=1,nres
8350 C       do i=1,1
8351         if (itype(i).eq.ntyp1) cycle
8352
8353         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8354         if (positi.le.0) positi=positi+boxzsize
8355 C        print *,i
8356 C first for peptide groups
8357 c for each residue check if it is in lipid or lipid water border area
8358        if ((positi.gt.bordlipbot)
8359      &.and.(positi.lt.bordliptop)) then
8360 C the energy transfer exist
8361         if (positi.lt.buflipbot) then
8362 C what fraction I am in
8363          fracinbuf=1.0d0-
8364      &        ((positi-bordlipbot)/lipbufthick)
8365 C lipbufthick is thickenes of lipid buffore
8366          sslip=sscalelip(fracinbuf)
8367          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8368          eliptran=eliptran+sslip*pepliptran
8369          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8370          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8371 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8372         elseif (positi.gt.bufliptop) then
8373          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8374          sslip=sscalelip(fracinbuf)
8375          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8376          eliptran=eliptran+sslip*pepliptran
8377          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8378          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8379 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8380 C          print *, "doing sscalefor top part"
8381 C         print *,i,sslip,fracinbuf,ssgradlip
8382         else
8383          eliptran=eliptran+pepliptran
8384 C         print *,"I am in true lipid"
8385         endif
8386 C       else
8387 C       eliptran=elpitran+0.0 ! I am in water
8388        endif
8389        enddo
8390 C       print *, "nic nie bylo w lipidzie?"
8391 C now multiply all by the peptide group transfer factor
8392 C       eliptran=eliptran*pepliptran
8393 C now the same for side chains
8394 CV       do i=1,1
8395        do i=1,nres
8396         if (itype(i).eq.ntyp1) cycle
8397         positi=(mod(c(3,i+nres),boxzsize))
8398         if (positi.le.0) positi=positi+boxzsize
8399 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8400 c for each residue check if it is in lipid or lipid water border area
8401 C       respos=mod(c(3,i+nres),boxzsize)
8402 C       print *,positi,bordlipbot,buflipbot
8403        if ((positi.gt.bordlipbot)
8404      & .and.(positi.lt.bordliptop)) then
8405 C the energy transfer exist
8406         if (positi.lt.buflipbot) then
8407          fracinbuf=1.0d0-
8408      &     ((positi-bordlipbot)/lipbufthick)
8409 C lipbufthick is thickenes of lipid buffore
8410          sslip=sscalelip(fracinbuf)
8411          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8412          eliptran=eliptran+sslip*liptranene(itype(i))
8413          gliptranx(3,i)=gliptranx(3,i)
8414      &+ssgradlip*liptranene(itype(i))
8415          gliptranc(3,i-1)= gliptranc(3,i-1)
8416      &+ssgradlip*liptranene(itype(i))
8417 C         print *,"doing sccale for lower part"
8418         elseif (positi.gt.bufliptop) then
8419          fracinbuf=1.0d0-
8420      &((bordliptop-positi)/lipbufthick)
8421          sslip=sscalelip(fracinbuf)
8422          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8423          eliptran=eliptran+sslip*liptranene(itype(i))
8424          gliptranx(3,i)=gliptranx(3,i)
8425      &+ssgradlip*liptranene(itype(i))
8426          gliptranc(3,i-1)= gliptranc(3,i-1)
8427      &+ssgradlip*liptranene(itype(i))
8428 C          print *, "doing sscalefor top part",sslip,fracinbuf
8429         else
8430          eliptran=eliptran+liptranene(itype(i))
8431 C         print *,"I am in true lipid"
8432         endif
8433         endif ! if in lipid or buffor
8434 C       else
8435 C       eliptran=elpitran+0.0 ! I am in water
8436        enddo
8437        return
8438        end
8439
8440
8441 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8442
8443       SUBROUTINE MATVEC2(A1,V1,V2)
8444       implicit real*8 (a-h,o-z)
8445       include 'DIMENSIONS'
8446       DIMENSION A1(2,2),V1(2),V2(2)
8447 c      DO 1 I=1,2
8448 c        VI=0.0
8449 c        DO 3 K=1,2
8450 c    3     VI=VI+A1(I,K)*V1(K)
8451 c        Vaux(I)=VI
8452 c    1 CONTINUE
8453
8454       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8455       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8456
8457       v2(1)=vaux1
8458       v2(2)=vaux2
8459       END
8460 C---------------------------------------
8461       SUBROUTINE MATMAT2(A1,A2,A3)
8462       implicit real*8 (a-h,o-z)
8463       include 'DIMENSIONS'
8464       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8465 c      DIMENSION AI3(2,2)
8466 c        DO  J=1,2
8467 c          A3IJ=0.0
8468 c          DO K=1,2
8469 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8470 c          enddo
8471 c          A3(I,J)=A3IJ
8472 c       enddo
8473 c      enddo
8474
8475       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8476       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8477       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8478       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8479
8480       A3(1,1)=AI3_11
8481       A3(2,1)=AI3_21
8482       A3(1,2)=AI3_12
8483       A3(2,2)=AI3_22
8484       END
8485
8486 c-------------------------------------------------------------------------
8487       double precision function scalar2(u,v)
8488       implicit none
8489       double precision u(2),v(2)
8490       double precision sc
8491       integer i
8492       scalar2=u(1)*v(1)+u(2)*v(2)
8493       return
8494       end
8495
8496 C-----------------------------------------------------------------------------
8497
8498       subroutine transpose2(a,at)
8499       implicit none
8500       double precision a(2,2),at(2,2)
8501       at(1,1)=a(1,1)
8502       at(1,2)=a(2,1)
8503       at(2,1)=a(1,2)
8504       at(2,2)=a(2,2)
8505       return
8506       end
8507 c--------------------------------------------------------------------------
8508       subroutine transpose(n,a,at)
8509       implicit none
8510       integer n,i,j
8511       double precision a(n,n),at(n,n)
8512       do i=1,n
8513         do j=1,n
8514           at(j,i)=a(i,j)
8515         enddo
8516       enddo
8517       return
8518       end
8519 C---------------------------------------------------------------------------
8520       subroutine prodmat3(a1,a2,kk,transp,prod)
8521       implicit none
8522       integer i,j
8523       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8524       logical transp
8525 crc      double precision auxmat(2,2),prod_(2,2)
8526
8527       if (transp) then
8528 crc        call transpose2(kk(1,1),auxmat(1,1))
8529 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8530 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8531
8532            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8533      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8534            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8535      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8536            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8537      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8538            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8539      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8540
8541       else
8542 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8543 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8544
8545            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8546      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8547            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8548      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8549            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8550      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8551            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8552      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8553
8554       endif
8555 c      call transpose2(a2(1,1),a2t(1,1))
8556
8557 crc      print *,transp
8558 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8559 crc      print *,((prod(i,j),i=1,2),j=1,2)
8560
8561       return
8562       end
8563 C-----------------------------------------------------------------------------
8564       double precision function scalar(u,v)
8565       implicit none
8566       double precision u(3),v(3)
8567       double precision sc
8568       integer i
8569       sc=0.0d0
8570       do i=1,3
8571         sc=sc+u(i)*v(i)
8572       enddo
8573       scalar=sc
8574       return
8575       end
8576 C-----------------------------------------------------------------------
8577       double precision function sscale(r)
8578       double precision r,gamm
8579       include "COMMON.SPLITELE"
8580       if(r.lt.r_cut-rlamb) then
8581         sscale=1.0d0
8582       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8583         gamm=(r-(r_cut-rlamb))/rlamb
8584         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8585       else
8586         sscale=0d0
8587       endif
8588       return
8589       end
8590 C-----------------------------------------------------------------------
8591 C-----------------------------------------------------------------------
8592       double precision function sscagrad(r)
8593       double precision r,gamm
8594       include "COMMON.SPLITELE"
8595       if(r.lt.r_cut-rlamb) then
8596         sscagrad=0.0d0
8597       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8598         gamm=(r-(r_cut-rlamb))/rlamb
8599         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8600       else
8601         sscagrad=0.0d0
8602       endif
8603       return
8604       end
8605 C-----------------------------------------------------------------------
8606 C-----------------------------------------------------------------------
8607       double precision function sscalelip(r)
8608       double precision r,gamm
8609       include "COMMON.SPLITELE"
8610 C      if(r.lt.r_cut-rlamb) then
8611 C        sscale=1.0d0
8612 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8613 C        gamm=(r-(r_cut-rlamb))/rlamb
8614         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8615 C      else
8616 C        sscale=0d0
8617 C      endif
8618       return
8619       end
8620 C-----------------------------------------------------------------------
8621       double precision function sscagradlip(r)
8622       double precision r,gamm
8623       include "COMMON.SPLITELE"
8624 C     if(r.lt.r_cut-rlamb) then
8625 C        sscagrad=0.0d0
8626 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8627 C        gamm=(r-(r_cut-rlamb))/rlamb
8628         sscagradlip=r*(6*r-6.0d0)
8629 C      else
8630 C        sscagrad=0.0d0
8631 C      endif
8632       return
8633       end
8634
8635 C-----------------------------------------------------------------------
8636        subroutine set_shield_fac
8637       implicit real*8 (a-h,o-z)
8638       include 'DIMENSIONS'
8639       include 'COMMON.CHAIN'
8640       include 'COMMON.DERIV'
8641       include 'COMMON.IOUNITS'
8642       include 'COMMON.SHIELD'
8643       include 'COMMON.INTERACT'
8644 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8645       double precision div77_81/0.974996043d0/,
8646      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8647
8648 C the vector between center of side_chain and peptide group
8649        double precision pep_side(3),long,side_calf(3),
8650      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8651      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8652 C the line belowe needs to be changed for FGPROC>1
8653       do i=1,nres-1
8654       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8655       ishield_list(i)=0
8656 Cif there two consequtive dummy atoms there is no peptide group between them
8657 C the line below has to be changed for FGPROC>1
8658       VolumeTotal=0.0
8659       do k=1,nres
8660        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8661        dist_pep_side=0.0
8662        dist_side_calf=0.0
8663        do j=1,3
8664 C first lets set vector conecting the ithe side-chain with kth side-chain
8665       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8666 C      pep_side(j)=2.0d0
8667 C and vector conecting the side-chain with its proper calfa
8668       side_calf(j)=c(j,k+nres)-c(j,k)
8669 C      side_calf(j)=2.0d0
8670       pept_group(j)=c(j,i)-c(j,i+1)
8671 C lets have their lenght
8672       dist_pep_side=pep_side(j)**2+dist_pep_side
8673       dist_side_calf=dist_side_calf+side_calf(j)**2
8674       dist_pept_group=dist_pept_group+pept_group(j)**2
8675       enddo
8676        dist_pep_side=dsqrt(dist_pep_side)
8677        dist_pept_group=dsqrt(dist_pept_group)
8678        dist_side_calf=dsqrt(dist_side_calf)
8679       do j=1,3
8680         pep_side_norm(j)=pep_side(j)/dist_pep_side
8681         side_calf_norm(j)=dist_side_calf
8682       enddo
8683 C now sscale fraction
8684        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8685 C       print *,buff_shield,"buff"
8686 C now sscale
8687         if (sh_frac_dist.le.0.0) cycle
8688 C If we reach here it means that this side chain reaches the shielding sphere
8689 C Lets add him to the list for gradient
8690         ishield_list(i)=ishield_list(i)+1
8691 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8692 C this list is essential otherwise problem would be O3
8693         shield_list(ishield_list(i),i)=k
8694 C Lets have the sscale value
8695         if (sh_frac_dist.gt.1.0) then
8696          scale_fac_dist=1.0d0
8697          do j=1,3
8698          sh_frac_dist_grad(j)=0.0d0
8699          enddo
8700         else
8701          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8702      &                   *(2.0*sh_frac_dist-3.0d0)
8703          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8704      &                  /dist_pep_side/buff_shield*0.5
8705 C remember for the final gradient multiply sh_frac_dist_grad(j)
8706 C for side_chain by factor -2 !
8707          do j=1,3
8708          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8709 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8710 C     &                    sh_frac_dist_grad(j)
8711          enddo
8712         endif
8713 C        if ((i.eq.3).and.(k.eq.2)) then
8714 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8715 C     & ,"TU"
8716 C        endif
8717
8718 C this is what is now we have the distance scaling now volume...
8719       short=short_r_sidechain(itype(k))
8720       long=long_r_sidechain(itype(k))
8721       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8722 C now costhet_grad
8723 C       costhet=0.0d0
8724        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8725 C       costhet_fac=0.0d0
8726        do j=1,3
8727          costhet_grad(j)=costhet_fac*pep_side(j)
8728        enddo
8729 C remember for the final gradient multiply costhet_grad(j)
8730 C for side_chain by factor -2 !
8731 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8732 C pep_side0pept_group is vector multiplication
8733       pep_side0pept_group=0.0
8734       do j=1,3
8735       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8736       enddo
8737       cosalfa=(pep_side0pept_group/
8738      & (dist_pep_side*dist_side_calf))
8739       fac_alfa_sin=1.0-cosalfa**2
8740       fac_alfa_sin=dsqrt(fac_alfa_sin)
8741       rkprim=fac_alfa_sin*(long-short)+short
8742 C now costhet_grad
8743        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8744        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8745
8746        do j=1,3
8747          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8748      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8749      &*(long-short)/fac_alfa_sin*cosalfa/
8750      &((dist_pep_side*dist_side_calf))*
8751      &((side_calf(j))-cosalfa*
8752      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8753
8754         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8755      &*(long-short)/fac_alfa_sin*cosalfa
8756      &/((dist_pep_side*dist_side_calf))*
8757      &(pep_side(j)-
8758      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8759        enddo
8760
8761       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8762      &                    /VSolvSphere_div
8763      &                    *wshield
8764 C now the gradient...
8765 C grad_shield is gradient of Calfa for peptide groups
8766 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8767 C     &               costhet,cosphi
8768 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8769 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8770       do j=1,3
8771       grad_shield(j,i)=grad_shield(j,i)
8772 C gradient po skalowaniu
8773      &                +(sh_frac_dist_grad(j)
8774 C  gradient po costhet
8775      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8776      &-scale_fac_dist*(cosphi_grad_long(j))
8777      &/(1.0-cosphi) )*div77_81
8778      &*VofOverlap
8779 C grad_shield_side is Cbeta sidechain gradient
8780       grad_shield_side(j,ishield_list(i),i)=
8781      &        (sh_frac_dist_grad(j)*-2.0d0
8782      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8783      &       +scale_fac_dist*(cosphi_grad_long(j))
8784      &        *2.0d0/(1.0-cosphi))
8785      &        *div77_81*VofOverlap
8786
8787        grad_shield_loc(j,ishield_list(i),i)=
8788      &   scale_fac_dist*cosphi_grad_loc(j)
8789      &        *2.0d0/(1.0-cosphi)
8790      &        *div77_81*VofOverlap
8791       enddo
8792       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8793       enddo
8794       fac_shield(i)=VolumeTotal*div77_81+div4_81
8795 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8796       enddo
8797       return
8798       end
8799 C--------------------------------------------------------------------------
8800 C first for shielding is setting of function of side-chains
8801        subroutine set_shield_fac2
8802       implicit real*8 (a-h,o-z)
8803       include 'DIMENSIONS'
8804       include 'COMMON.CHAIN'
8805       include 'COMMON.DERIV'
8806       include 'COMMON.IOUNITS'
8807       include 'COMMON.SHIELD'
8808       include 'COMMON.INTERACT'
8809 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8810       double precision div77_81/0.974996043d0/,
8811      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8812
8813 C the vector between center of side_chain and peptide group
8814        double precision pep_side(3),long,side_calf(3),
8815      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8816      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8817 C the line belowe needs to be changed for FGPROC>1
8818       do i=1,nres-1
8819       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8820       ishield_list(i)=0
8821 Cif there two consequtive dummy atoms there is no peptide group between them
8822 C the line below has to be changed for FGPROC>1
8823       VolumeTotal=0.0
8824       do k=1,nres
8825        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8826        dist_pep_side=0.0
8827        dist_side_calf=0.0
8828        do j=1,3
8829 C first lets set vector conecting the ithe side-chain with kth side-chain
8830       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8831 C      pep_side(j)=2.0d0
8832 C and vector conecting the side-chain with its proper calfa
8833       side_calf(j)=c(j,k+nres)-c(j,k)
8834 C      side_calf(j)=2.0d0
8835       pept_group(j)=c(j,i)-c(j,i+1)
8836 C lets have their lenght
8837       dist_pep_side=pep_side(j)**2+dist_pep_side
8838       dist_side_calf=dist_side_calf+side_calf(j)**2
8839       dist_pept_group=dist_pept_group+pept_group(j)**2
8840       enddo
8841        dist_pep_side=dsqrt(dist_pep_side)
8842        dist_pept_group=dsqrt(dist_pept_group)
8843        dist_side_calf=dsqrt(dist_side_calf)
8844       do j=1,3
8845         pep_side_norm(j)=pep_side(j)/dist_pep_side
8846         side_calf_norm(j)=dist_side_calf
8847       enddo
8848 C now sscale fraction
8849        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8850 C       print *,buff_shield,"buff"
8851 C now sscale
8852         if (sh_frac_dist.le.0.0) cycle
8853 C If we reach here it means that this side chain reaches the shielding sphere
8854 C Lets add him to the list for gradient
8855         ishield_list(i)=ishield_list(i)+1
8856 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8857 C this list is essential otherwise problem would be O3
8858         shield_list(ishield_list(i),i)=k
8859 C Lets have the sscale value
8860         if (sh_frac_dist.gt.1.0) then
8861          scale_fac_dist=1.0d0
8862          do j=1,3
8863          sh_frac_dist_grad(j)=0.0d0
8864          enddo
8865         else
8866          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8867      &                   *(2.0d0*sh_frac_dist-3.0d0)
8868          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8869      &                  /dist_pep_side/buff_shield*0.5d0
8870 C remember for the final gradient multiply sh_frac_dist_grad(j)
8871 C for side_chain by factor -2 !
8872          do j=1,3
8873          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8874 C         sh_frac_dist_grad(j)=0.0d0
8875 C         scale_fac_dist=1.0d0
8876 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8877 C     &                    sh_frac_dist_grad(j)
8878          enddo
8879         endif
8880 C this is what is now we have the distance scaling now volume...
8881       short=short_r_sidechain(itype(k))
8882       long=long_r_sidechain(itype(k))
8883       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8884       sinthet=short/dist_pep_side*costhet
8885 C now costhet_grad
8886 C       costhet=0.6d0
8887 C       sinthet=0.8
8888        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8889 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8890 C     &             -short/dist_pep_side**2/costhet)
8891 C       costhet_fac=0.0d0
8892        do j=1,3
8893          costhet_grad(j)=costhet_fac*pep_side(j)
8894        enddo
8895 C remember for the final gradient multiply costhet_grad(j)
8896 C for side_chain by factor -2 !
8897 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8898 C pep_side0pept_group is vector multiplication
8899       pep_side0pept_group=0.0d0
8900       do j=1,3
8901       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8902       enddo
8903       cosalfa=(pep_side0pept_group/
8904      & (dist_pep_side*dist_side_calf))
8905       fac_alfa_sin=1.0d0-cosalfa**2
8906       fac_alfa_sin=dsqrt(fac_alfa_sin)
8907       rkprim=fac_alfa_sin*(long-short)+short
8908 C      rkprim=short
8909
8910 C now costhet_grad
8911        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8912 C       cosphi=0.6
8913        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8914        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8915      &      dist_pep_side**2)
8916 C       sinphi=0.8
8917        do j=1,3
8918          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8919      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8920      &*(long-short)/fac_alfa_sin*cosalfa/
8921      &((dist_pep_side*dist_side_calf))*
8922      &((side_calf(j))-cosalfa*
8923      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8924 C       cosphi_grad_long(j)=0.0d0
8925         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8926      &*(long-short)/fac_alfa_sin*cosalfa
8927      &/((dist_pep_side*dist_side_calf))*
8928      &(pep_side(j)-
8929      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8930 C       cosphi_grad_loc(j)=0.0d0
8931        enddo
8932 C      print *,sinphi,sinthet
8933       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
8934      &                    /VSolvSphere_div
8935 C     &                    *wshield
8936 C now the gradient...
8937       do j=1,3
8938       grad_shield(j,i)=grad_shield(j,i)
8939 C gradient po skalowaniu
8940      &                +(sh_frac_dist_grad(j)*VofOverlap
8941 C  gradient po costhet
8942      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
8943      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8944      &       sinphi/sinthet*costhet*costhet_grad(j)
8945      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8946      & )*wshield
8947 C grad_shield_side is Cbeta sidechain gradient
8948       grad_shield_side(j,ishield_list(i),i)=
8949      &        (sh_frac_dist_grad(j)*-2.0d0
8950      &        *VofOverlap
8951      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8952      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8953      &       sinphi/sinthet*costhet*costhet_grad(j)
8954      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8955      &       )*wshield
8956
8957        grad_shield_loc(j,ishield_list(i),i)=
8958      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8959      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
8960      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
8961      &        ))
8962      &        *wshield
8963       enddo
8964       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8965       enddo
8966       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
8967 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8968 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
8969       enddo
8970       return
8971       end
8972