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,xshift,yshift,zshift
 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,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1038
1039 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1040 C checking the distance
1041       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1042       xj_safe=xj
1043       yj_safe=yj
1044       zj_safe=zj
1045       subchap=0
1046 C finding the closest
1047       do xshift=-1,1
1048       do yshift=-1,1
1049       do zshift=-1,1
1050           xj=xj_safe+xshift*boxxsize
1051           yj=yj_safe+yshift*boxysize
1052           zj=zj_safe+zshift*boxzsize
1053           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1054           if(dist_temp.lt.dist_init) then
1055             dist_init=dist_temp
1056             xj_temp=xj
1057             yj_temp=yj
1058             zj_temp=zj
1059             subchap=1
1060           endif
1061        enddo
1062        enddo
1063        enddo
1064        if (subchap.eq.1) then
1065           xj=xj_temp-xi
1066           yj=yj_temp-yi
1067           zj=zj_temp-zi
1068        else
1069           xj=xj_safe-xi
1070           yj=yj_safe-yi
1071           zj=zj_safe-zi
1072        endif
1073
1074             dxj=dc_norm(1,nres+j)
1075             dyj=dc_norm(2,nres+j)
1076             dzj=dc_norm(3,nres+j)
1077 c            write (iout,*) i,j,xj,yj,zj
1078             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1079             rij=dsqrt(rrij)
1080             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1081             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1082             if (sss.le.0.0) cycle
1083 C Calculate angle-dependent terms of energy and contributions to their
1084 C derivatives.
1085
1086             call sc_angular
1087             sigsq=1.0D0/sigsq
1088             sig=sig0ij*dsqrt(sigsq)
1089             rij_shift=1.0D0/rij-sig+sig0ij
1090 C I hate to put IF's in the loops, but here don't have another choice!!!!
1091             if (rij_shift.le.0.0D0) then
1092               evdw=1.0D20
1093               return
1094             endif
1095             sigder=-sig*sigsq
1096 c---------------------------------------------------------------
1097             rij_shift=1.0D0/rij_shift
1098             fac=rij_shift**expon
1099             e1=fac*fac*aa
1100             e2=fac*bb
1101             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1102             eps2der=evdwij*eps3rt
1103             eps3der=evdwij*eps2rt
1104             evdwij=evdwij*eps2rt*eps3rt
1105             if (bb.gt.0) then
1106               evdw=evdw+evdwij*sss
1107             else
1108               evdw_t=evdw_t+evdwij*sss
1109             endif
1110             ij=icant(itypi,itypj)
1111             aux=eps1*eps2rt**2*eps3rt**2
1112             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1113      &        /dabs(eps(itypi,itypj))
1114             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1115 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1116 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1117 c     &         aux*e2/eps(itypi,itypj)
1118 c            if (lprn) then
1119             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1120             epsi=bb**2/aa
1121 #ifdef DEBUG
1122             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1123      &        restyp(itypi),i,restyp(itypj),j,
1124      &        epsi,sigm,chi1,chi2,chip1,chip2,
1125      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1126      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1127      &        evdwij
1128              write (iout,*) "partial sum", evdw, evdw_t
1129 #endif
1130 c            endif
1131             if (calc_grad) then
1132 C Calculate gradient components.
1133             e1=e1*eps1*eps2rt**2*eps3rt**2
1134             fac=-expon*(e1+evdwij)*rij_shift
1135             sigder=fac*sigder
1136             fac=rij*fac
1137             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1138 C Calculate the radial part of the gradient
1139             gg(1)=xj*fac
1140             gg(2)=yj*fac
1141             gg(3)=zj*fac
1142 C Calculate angular part of the gradient.
1143             call sc_grad
1144             endif
1145 C            write(iout,*)  "partial sum", evdw, evdw_t
1146             ENDIF    ! dyn_ss
1147           enddo      ! j
1148         enddo        ! iint
1149       enddo          ! i
1150       return
1151       end
1152 C-----------------------------------------------------------------------------
1153       subroutine egbv(evdw,evdw_t)
1154 C
1155 C This subroutine calculates the interaction energy of nonbonded side chains
1156 C assuming the Gay-Berne-Vorobjev potential of interaction.
1157 C
1158       implicit real*8 (a-h,o-z)
1159       include 'DIMENSIONS'
1160       include 'DIMENSIONS.ZSCOPT'
1161       include "DIMENSIONS.COMPAR"
1162       include 'COMMON.GEO'
1163       include 'COMMON.VAR'
1164       include 'COMMON.LOCAL'
1165       include 'COMMON.CHAIN'
1166       include 'COMMON.DERIV'
1167       include 'COMMON.NAMES'
1168       include 'COMMON.INTERACT'
1169       include 'COMMON.ENEPS'
1170       include 'COMMON.IOUNITS'
1171       include 'COMMON.CALC'
1172       common /srutu/ icall
1173       logical lprn
1174       integer icant
1175       external icant
1176       do i=1,210
1177         do j=1,2
1178           eneps_temp(j,i)=0.0d0
1179         enddo
1180       enddo
1181       evdw=0.0D0
1182       evdw_t=0.0d0
1183 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1184       evdw=0.0D0
1185       lprn=.false.
1186 c      if (icall.gt.0) lprn=.true.
1187       ind=0
1188       do i=iatsc_s,iatsc_e
1189         itypi=iabs(itype(i))
1190         if (itypi.eq.ntyp1) cycle
1191         itypi1=iabs(itype(i+1))
1192         xi=c(1,nres+i)
1193         yi=c(2,nres+i)
1194         zi=c(3,nres+i)
1195         dxi=dc_norm(1,nres+i)
1196         dyi=dc_norm(2,nres+i)
1197         dzi=dc_norm(3,nres+i)
1198         dsci_inv=vbld_inv(i+nres)
1199 C
1200 C Calculate SC interaction energy.
1201 C
1202         do iint=1,nint_gr(i)
1203           do j=istart(i,iint),iend(i,iint)
1204             ind=ind+1
1205             itypj=iabs(itype(j))
1206             if (itypj.eq.ntyp1) cycle
1207             dscj_inv=vbld_inv(j+nres)
1208             sig0ij=sigma(itypi,itypj)
1209             r0ij=r0(itypi,itypj)
1210             chi1=chi(itypi,itypj)
1211             chi2=chi(itypj,itypi)
1212             chi12=chi1*chi2
1213             chip1=chip(itypi)
1214             chip2=chip(itypj)
1215             chip12=chip1*chip2
1216             alf1=alp(itypi)
1217             alf2=alp(itypj)
1218             alf12=0.5D0*(alf1+alf2)
1219 C For diagnostics only!!!
1220 c           chi1=0.0D0
1221 c           chi2=0.0D0
1222 c           chi12=0.0D0
1223 c           chip1=0.0D0
1224 c           chip2=0.0D0
1225 c           chip12=0.0D0
1226 c           alf1=0.0D0
1227 c           alf2=0.0D0
1228 c           alf12=0.0D0
1229             xj=c(1,nres+j)-xi
1230             yj=c(2,nres+j)-yi
1231             zj=c(3,nres+j)-zi
1232             dxj=dc_norm(1,nres+j)
1233             dyj=dc_norm(2,nres+j)
1234             dzj=dc_norm(3,nres+j)
1235             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1236             rij=dsqrt(rrij)
1237 C Calculate angle-dependent terms of energy and contributions to their
1238 C derivatives.
1239             call sc_angular
1240             sigsq=1.0D0/sigsq
1241             sig=sig0ij*dsqrt(sigsq)
1242             rij_shift=1.0D0/rij-sig+r0ij
1243 C I hate to put IF's in the loops, but here don't have another choice!!!!
1244             if (rij_shift.le.0.0D0) then
1245               evdw=1.0D20
1246               return
1247             endif
1248             sigder=-sig*sigsq
1249 c---------------------------------------------------------------
1250             rij_shift=1.0D0/rij_shift
1251             fac=rij_shift**expon
1252             e1=fac*fac*aa
1253             e2=fac*bb
1254             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1255             eps2der=evdwij*eps3rt
1256             eps3der=evdwij*eps2rt
1257             fac_augm=rrij**expon
1258             e_augm=augm(itypi,itypj)*fac_augm
1259             evdwij=evdwij*eps2rt*eps3rt
1260             if (bb.gt.0.0d0) then
1261               evdw=evdw+evdwij+e_augm
1262             else
1263               evdw_t=evdw_t+evdwij+e_augm
1264             endif
1265             ij=icant(itypi,itypj)
1266             aux=eps1*eps2rt**2*eps3rt**2
1267             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1268      &        /dabs(eps(itypi,itypj))
1269             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1270 c            eneps_temp(ij)=eneps_temp(ij)
1271 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1272 c            if (lprn) then
1273 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1274 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1275 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1276 c     &        restyp(itypi),i,restyp(itypj),j,
1277 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1278 c     &        chi1,chi2,chip1,chip2,
1279 c     &        eps1,eps2rt**2,eps3rt**2,
1280 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1281 c     &        evdwij+e_augm
1282 c            endif
1283             if (calc_grad) then
1284 C Calculate gradient components.
1285             e1=e1*eps1*eps2rt**2*eps3rt**2
1286             fac=-expon*(e1+evdwij)*rij_shift
1287             sigder=fac*sigder
1288             fac=rij*fac-2*expon*rrij*e_augm
1289 C Calculate the radial part of the gradient
1290             gg(1)=xj*fac
1291             gg(2)=yj*fac
1292             gg(3)=zj*fac
1293 C Calculate angular part of the gradient.
1294             call sc_grad
1295             endif
1296           enddo      ! j
1297         enddo        ! iint
1298       enddo          ! i
1299       return
1300       end
1301 C-----------------------------------------------------------------------------
1302       subroutine sc_angular
1303 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1304 C om12. Called by ebp, egb, and egbv.
1305       implicit none
1306       include 'COMMON.CALC'
1307       erij(1)=xj*rij
1308       erij(2)=yj*rij
1309       erij(3)=zj*rij
1310       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1311       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1312       om12=dxi*dxj+dyi*dyj+dzi*dzj
1313       chiom12=chi12*om12
1314 C Calculate eps1(om12) and its derivative in om12
1315       faceps1=1.0D0-om12*chiom12
1316       faceps1_inv=1.0D0/faceps1
1317       eps1=dsqrt(faceps1_inv)
1318 C Following variable is eps1*deps1/dom12
1319       eps1_om12=faceps1_inv*chiom12
1320 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1321 C and om12.
1322       om1om2=om1*om2
1323       chiom1=chi1*om1
1324       chiom2=chi2*om2
1325       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1326       sigsq=1.0D0-facsig*faceps1_inv
1327       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1328       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1329       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1330 C Calculate eps2 and its derivatives in om1, om2, and om12.
1331       chipom1=chip1*om1
1332       chipom2=chip2*om2
1333       chipom12=chip12*om12
1334       facp=1.0D0-om12*chipom12
1335       facp_inv=1.0D0/facp
1336       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1337 C Following variable is the square root of eps2
1338       eps2rt=1.0D0-facp1*facp_inv
1339 C Following three variables are the derivatives of the square root of eps
1340 C in om1, om2, and om12.
1341       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1342       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1343       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1344 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1345       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1346 C Calculate whole angle-dependent part of epsilon and contributions
1347 C to its derivatives
1348       return
1349       end
1350 C----------------------------------------------------------------------------
1351       subroutine sc_grad
1352       implicit real*8 (a-h,o-z)
1353       include 'DIMENSIONS'
1354       include 'DIMENSIONS.ZSCOPT'
1355       include 'COMMON.CHAIN'
1356       include 'COMMON.DERIV'
1357       include 'COMMON.CALC'
1358       double precision dcosom1(3),dcosom2(3)
1359       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1360       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1361       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1362      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1363       do k=1,3
1364         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1365         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1366       enddo
1367       do k=1,3
1368         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1369       enddo
1370       do k=1,3
1371         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1372      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1373      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1374         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1375      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1376      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1377       enddo
1378 C
1379 C Calculate the components of the gradient in DC and X
1380 C
1381       do k=i,j-1
1382         do l=1,3
1383           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1384         enddo
1385       enddo
1386       return
1387       end
1388 c------------------------------------------------------------------------------
1389       subroutine vec_and_deriv
1390       implicit real*8 (a-h,o-z)
1391       include 'DIMENSIONS'
1392       include 'DIMENSIONS.ZSCOPT'
1393       include 'COMMON.IOUNITS'
1394       include 'COMMON.GEO'
1395       include 'COMMON.VAR'
1396       include 'COMMON.LOCAL'
1397       include 'COMMON.CHAIN'
1398       include 'COMMON.VECTORS'
1399       include 'COMMON.DERIV'
1400       include 'COMMON.INTERACT'
1401       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1402 C Compute the local reference systems. For reference system (i), the
1403 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1404 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1405       do i=1,nres-1
1406 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1407           if (i.eq.nres-1) then
1408 C Case of the last full residue
1409 C Compute the Z-axis
1410             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1411             costh=dcos(pi-theta(nres))
1412             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1413             do k=1,3
1414               uz(k,i)=fac*uz(k,i)
1415             enddo
1416             if (calc_grad) then
1417 C Compute the derivatives of uz
1418             uzder(1,1,1)= 0.0d0
1419             uzder(2,1,1)=-dc_norm(3,i-1)
1420             uzder(3,1,1)= dc_norm(2,i-1)
1421             uzder(1,2,1)= dc_norm(3,i-1)
1422             uzder(2,2,1)= 0.0d0
1423             uzder(3,2,1)=-dc_norm(1,i-1)
1424             uzder(1,3,1)=-dc_norm(2,i-1)
1425             uzder(2,3,1)= dc_norm(1,i-1)
1426             uzder(3,3,1)= 0.0d0
1427             uzder(1,1,2)= 0.0d0
1428             uzder(2,1,2)= dc_norm(3,i)
1429             uzder(3,1,2)=-dc_norm(2,i)
1430             uzder(1,2,2)=-dc_norm(3,i)
1431             uzder(2,2,2)= 0.0d0
1432             uzder(3,2,2)= dc_norm(1,i)
1433             uzder(1,3,2)= dc_norm(2,i)
1434             uzder(2,3,2)=-dc_norm(1,i)
1435             uzder(3,3,2)= 0.0d0
1436             endif
1437 C Compute the Y-axis
1438             facy=fac
1439             do k=1,3
1440               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1441             enddo
1442             if (calc_grad) then
1443 C Compute the derivatives of uy
1444             do j=1,3
1445               do k=1,3
1446                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1447      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1448                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1449               enddo
1450               uyder(j,j,1)=uyder(j,j,1)-costh
1451               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1452             enddo
1453             do j=1,2
1454               do k=1,3
1455                 do l=1,3
1456                   uygrad(l,k,j,i)=uyder(l,k,j)
1457                   uzgrad(l,k,j,i)=uzder(l,k,j)
1458                 enddo
1459               enddo
1460             enddo
1461             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1462             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1463             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1464             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1465             endif
1466           else
1467 C Other residues
1468 C Compute the Z-axis
1469             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1470             costh=dcos(pi-theta(i+2))
1471             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1472             do k=1,3
1473               uz(k,i)=fac*uz(k,i)
1474             enddo
1475             if (calc_grad) then
1476 C Compute the derivatives of uz
1477             uzder(1,1,1)= 0.0d0
1478             uzder(2,1,1)=-dc_norm(3,i+1)
1479             uzder(3,1,1)= dc_norm(2,i+1)
1480             uzder(1,2,1)= dc_norm(3,i+1)
1481             uzder(2,2,1)= 0.0d0
1482             uzder(3,2,1)=-dc_norm(1,i+1)
1483             uzder(1,3,1)=-dc_norm(2,i+1)
1484             uzder(2,3,1)= dc_norm(1,i+1)
1485             uzder(3,3,1)= 0.0d0
1486             uzder(1,1,2)= 0.0d0
1487             uzder(2,1,2)= dc_norm(3,i)
1488             uzder(3,1,2)=-dc_norm(2,i)
1489             uzder(1,2,2)=-dc_norm(3,i)
1490             uzder(2,2,2)= 0.0d0
1491             uzder(3,2,2)= dc_norm(1,i)
1492             uzder(1,3,2)= dc_norm(2,i)
1493             uzder(2,3,2)=-dc_norm(1,i)
1494             uzder(3,3,2)= 0.0d0
1495             endif
1496 C Compute the Y-axis
1497             facy=fac
1498             do k=1,3
1499               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1500             enddo
1501             if (calc_grad) then
1502 C Compute the derivatives of uy
1503             do j=1,3
1504               do k=1,3
1505                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1506      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1507                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1508               enddo
1509               uyder(j,j,1)=uyder(j,j,1)-costh
1510               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1511             enddo
1512             do j=1,2
1513               do k=1,3
1514                 do l=1,3
1515                   uygrad(l,k,j,i)=uyder(l,k,j)
1516                   uzgrad(l,k,j,i)=uzder(l,k,j)
1517                 enddo
1518               enddo
1519             enddo
1520             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1521             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1522             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1523             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1524           endif
1525           endif
1526       enddo
1527       if (calc_grad) then
1528       do i=1,nres-1
1529         vbld_inv_temp(1)=vbld_inv(i+1)
1530         if (i.lt.nres-1) then
1531           vbld_inv_temp(2)=vbld_inv(i+2)
1532         else
1533           vbld_inv_temp(2)=vbld_inv(i)
1534         endif
1535         do j=1,2
1536           do k=1,3
1537             do l=1,3
1538               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1539               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1540             enddo
1541           enddo
1542         enddo
1543       enddo
1544       endif
1545       return
1546       end
1547 C-----------------------------------------------------------------------------
1548       subroutine vec_and_deriv_test
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'DIMENSIONS.ZSCOPT'
1552       include 'COMMON.IOUNITS'
1553       include 'COMMON.GEO'
1554       include 'COMMON.VAR'
1555       include 'COMMON.LOCAL'
1556       include 'COMMON.CHAIN'
1557       include 'COMMON.VECTORS'
1558       dimension uyder(3,3,2),uzder(3,3,2)
1559 C Compute the local reference systems. For reference system (i), the
1560 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1561 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1562       do i=1,nres-1
1563           if (i.eq.nres-1) then
1564 C Case of the last full residue
1565 C Compute the Z-axis
1566             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1567             costh=dcos(pi-theta(nres))
1568             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1569 c            write (iout,*) 'fac',fac,
1570 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1571             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1572             do k=1,3
1573               uz(k,i)=fac*uz(k,i)
1574             enddo
1575 C Compute the derivatives of uz
1576             uzder(1,1,1)= 0.0d0
1577             uzder(2,1,1)=-dc_norm(3,i-1)
1578             uzder(3,1,1)= dc_norm(2,i-1)
1579             uzder(1,2,1)= dc_norm(3,i-1)
1580             uzder(2,2,1)= 0.0d0
1581             uzder(3,2,1)=-dc_norm(1,i-1)
1582             uzder(1,3,1)=-dc_norm(2,i-1)
1583             uzder(2,3,1)= dc_norm(1,i-1)
1584             uzder(3,3,1)= 0.0d0
1585             uzder(1,1,2)= 0.0d0
1586             uzder(2,1,2)= dc_norm(3,i)
1587             uzder(3,1,2)=-dc_norm(2,i)
1588             uzder(1,2,2)=-dc_norm(3,i)
1589             uzder(2,2,2)= 0.0d0
1590             uzder(3,2,2)= dc_norm(1,i)
1591             uzder(1,3,2)= dc_norm(2,i)
1592             uzder(2,3,2)=-dc_norm(1,i)
1593             uzder(3,3,2)= 0.0d0
1594 C Compute the Y-axis
1595             do k=1,3
1596               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1597             enddo
1598             facy=fac
1599             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1600      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1601      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1602             do k=1,3
1603 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1604               uy(k,i)=
1605 c     &        facy*(
1606      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1607      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1608 c     &        )
1609             enddo
1610 c            write (iout,*) 'facy',facy,
1611 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1612             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1613             do k=1,3
1614               uy(k,i)=facy*uy(k,i)
1615             enddo
1616 C Compute the derivatives of uy
1617             do j=1,3
1618               do k=1,3
1619                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1620      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1621                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1622               enddo
1623 c              uyder(j,j,1)=uyder(j,j,1)-costh
1624 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1625               uyder(j,j,1)=uyder(j,j,1)
1626      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1627               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1628      &          +uyder(j,j,2)
1629             enddo
1630             do j=1,2
1631               do k=1,3
1632                 do l=1,3
1633                   uygrad(l,k,j,i)=uyder(l,k,j)
1634                   uzgrad(l,k,j,i)=uzder(l,k,j)
1635                 enddo
1636               enddo
1637             enddo
1638             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1639             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1640             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1641             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1642           else
1643 C Other residues
1644 C Compute the Z-axis
1645             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1646             costh=dcos(pi-theta(i+2))
1647             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1648             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1649             do k=1,3
1650               uz(k,i)=fac*uz(k,i)
1651             enddo
1652 C Compute the derivatives of uz
1653             uzder(1,1,1)= 0.0d0
1654             uzder(2,1,1)=-dc_norm(3,i+1)
1655             uzder(3,1,1)= dc_norm(2,i+1)
1656             uzder(1,2,1)= dc_norm(3,i+1)
1657             uzder(2,2,1)= 0.0d0
1658             uzder(3,2,1)=-dc_norm(1,i+1)
1659             uzder(1,3,1)=-dc_norm(2,i+1)
1660             uzder(2,3,1)= dc_norm(1,i+1)
1661             uzder(3,3,1)= 0.0d0
1662             uzder(1,1,2)= 0.0d0
1663             uzder(2,1,2)= dc_norm(3,i)
1664             uzder(3,1,2)=-dc_norm(2,i)
1665             uzder(1,2,2)=-dc_norm(3,i)
1666             uzder(2,2,2)= 0.0d0
1667             uzder(3,2,2)= dc_norm(1,i)
1668             uzder(1,3,2)= dc_norm(2,i)
1669             uzder(2,3,2)=-dc_norm(1,i)
1670             uzder(3,3,2)= 0.0d0
1671 C Compute the Y-axis
1672             facy=fac
1673             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1674      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1675      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1676             do k=1,3
1677 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1678               uy(k,i)=
1679 c     &        facy*(
1680      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1681      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1682 c     &        )
1683             enddo
1684 c            write (iout,*) 'facy',facy,
1685 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1686             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1687             do k=1,3
1688               uy(k,i)=facy*uy(k,i)
1689             enddo
1690 C Compute the derivatives of uy
1691             do j=1,3
1692               do k=1,3
1693                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1694      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1695                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1696               enddo
1697 c              uyder(j,j,1)=uyder(j,j,1)-costh
1698 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1699               uyder(j,j,1)=uyder(j,j,1)
1700      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1701               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1702      &          +uyder(j,j,2)
1703             enddo
1704             do j=1,2
1705               do k=1,3
1706                 do l=1,3
1707                   uygrad(l,k,j,i)=uyder(l,k,j)
1708                   uzgrad(l,k,j,i)=uzder(l,k,j)
1709                 enddo
1710               enddo
1711             enddo
1712             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1713             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1714             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1715             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1716           endif
1717       enddo
1718       do i=1,nres-1
1719         do j=1,2
1720           do k=1,3
1721             do l=1,3
1722               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1723               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1724             enddo
1725           enddo
1726         enddo
1727       enddo
1728       return
1729       end
1730 C-----------------------------------------------------------------------------
1731       subroutine check_vecgrad
1732       implicit real*8 (a-h,o-z)
1733       include 'DIMENSIONS'
1734       include 'DIMENSIONS.ZSCOPT'
1735       include 'COMMON.IOUNITS'
1736       include 'COMMON.GEO'
1737       include 'COMMON.VAR'
1738       include 'COMMON.LOCAL'
1739       include 'COMMON.CHAIN'
1740       include 'COMMON.VECTORS'
1741       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1742       dimension uyt(3,maxres),uzt(3,maxres)
1743       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1744       double precision delta /1.0d-7/
1745       call vec_and_deriv
1746 cd      do i=1,nres
1747 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1748 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1749 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1750 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1751 cd     &     (dc_norm(if90,i),if90=1,3)
1752 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1753 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1754 cd          write(iout,'(a)')
1755 cd      enddo
1756       do i=1,nres
1757         do j=1,2
1758           do k=1,3
1759             do l=1,3
1760               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1761               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1762             enddo
1763           enddo
1764         enddo
1765       enddo
1766       call vec_and_deriv
1767       do i=1,nres
1768         do j=1,3
1769           uyt(j,i)=uy(j,i)
1770           uzt(j,i)=uz(j,i)
1771         enddo
1772       enddo
1773       do i=1,nres
1774 cd        write (iout,*) 'i=',i
1775         do k=1,3
1776           erij(k)=dc_norm(k,i)
1777         enddo
1778         do j=1,3
1779           do k=1,3
1780             dc_norm(k,i)=erij(k)
1781           enddo
1782           dc_norm(j,i)=dc_norm(j,i)+delta
1783 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1784 c          do k=1,3
1785 c            dc_norm(k,i)=dc_norm(k,i)/fac
1786 c          enddo
1787 c          write (iout,*) (dc_norm(k,i),k=1,3)
1788 c          write (iout,*) (erij(k),k=1,3)
1789           call vec_and_deriv
1790           do k=1,3
1791             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1792             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1793             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1794             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1795           enddo
1796 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1797 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1798 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1799         enddo
1800         do k=1,3
1801           dc_norm(k,i)=erij(k)
1802         enddo
1803 cd        do k=1,3
1804 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1805 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1806 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1807 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1808 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1809 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1810 cd          write (iout,'(a)')
1811 cd        enddo
1812       enddo
1813       return
1814       end
1815 C--------------------------------------------------------------------------
1816       subroutine set_matrices
1817       implicit real*8 (a-h,o-z)
1818       include 'DIMENSIONS'
1819       include 'DIMENSIONS.ZSCOPT'
1820       include 'COMMON.IOUNITS'
1821       include 'COMMON.GEO'
1822       include 'COMMON.VAR'
1823       include 'COMMON.LOCAL'
1824       include 'COMMON.CHAIN'
1825       include 'COMMON.DERIV'
1826       include 'COMMON.INTERACT'
1827       include 'COMMON.CONTACTS'
1828       include 'COMMON.TORSION'
1829       include 'COMMON.VECTORS'
1830       include 'COMMON.FFIELD'
1831       double precision auxvec(2),auxmat(2,2)
1832 C
1833 C Compute the virtual-bond-torsional-angle dependent quantities needed
1834 C to calculate the el-loc multibody terms of various order.
1835 C
1836       do i=3,nres+1
1837         if (i .lt. nres+1) then
1838           sin1=dsin(phi(i))
1839           cos1=dcos(phi(i))
1840           sintab(i-2)=sin1
1841           costab(i-2)=cos1
1842           obrot(1,i-2)=cos1
1843           obrot(2,i-2)=sin1
1844           sin2=dsin(2*phi(i))
1845           cos2=dcos(2*phi(i))
1846           sintab2(i-2)=sin2
1847           costab2(i-2)=cos2
1848           obrot2(1,i-2)=cos2
1849           obrot2(2,i-2)=sin2
1850           Ug(1,1,i-2)=-cos1
1851           Ug(1,2,i-2)=-sin1
1852           Ug(2,1,i-2)=-sin1
1853           Ug(2,2,i-2)= cos1
1854           Ug2(1,1,i-2)=-cos2
1855           Ug2(1,2,i-2)=-sin2
1856           Ug2(2,1,i-2)=-sin2
1857           Ug2(2,2,i-2)= cos2
1858         else
1859           costab(i-2)=1.0d0
1860           sintab(i-2)=0.0d0
1861           obrot(1,i-2)=1.0d0
1862           obrot(2,i-2)=0.0d0
1863           obrot2(1,i-2)=0.0d0
1864           obrot2(2,i-2)=0.0d0
1865           Ug(1,1,i-2)=1.0d0
1866           Ug(1,2,i-2)=0.0d0
1867           Ug(2,1,i-2)=0.0d0
1868           Ug(2,2,i-2)=1.0d0
1869           Ug2(1,1,i-2)=0.0d0
1870           Ug2(1,2,i-2)=0.0d0
1871           Ug2(2,1,i-2)=0.0d0
1872           Ug2(2,2,i-2)=0.0d0
1873         endif
1874         if (i .gt. 3 .and. i .lt. nres+1) then
1875           obrot_der(1,i-2)=-sin1
1876           obrot_der(2,i-2)= cos1
1877           Ugder(1,1,i-2)= sin1
1878           Ugder(1,2,i-2)=-cos1
1879           Ugder(2,1,i-2)=-cos1
1880           Ugder(2,2,i-2)=-sin1
1881           dwacos2=cos2+cos2
1882           dwasin2=sin2+sin2
1883           obrot2_der(1,i-2)=-dwasin2
1884           obrot2_der(2,i-2)= dwacos2
1885           Ug2der(1,1,i-2)= dwasin2
1886           Ug2der(1,2,i-2)=-dwacos2
1887           Ug2der(2,1,i-2)=-dwacos2
1888           Ug2der(2,2,i-2)=-dwasin2
1889         else
1890           obrot_der(1,i-2)=0.0d0
1891           obrot_der(2,i-2)=0.0d0
1892           Ugder(1,1,i-2)=0.0d0
1893           Ugder(1,2,i-2)=0.0d0
1894           Ugder(2,1,i-2)=0.0d0
1895           Ugder(2,2,i-2)=0.0d0
1896           obrot2_der(1,i-2)=0.0d0
1897           obrot2_der(2,i-2)=0.0d0
1898           Ug2der(1,1,i-2)=0.0d0
1899           Ug2der(1,2,i-2)=0.0d0
1900           Ug2der(2,1,i-2)=0.0d0
1901           Ug2der(2,2,i-2)=0.0d0
1902         endif
1903         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1904           if (itype(i-2).le.ntyp) then
1905             iti = itortyp(itype(i-2))
1906           else
1907             iti=ntortyp+1
1908           endif
1909         else
1910           iti=ntortyp+1
1911         endif
1912         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1913           if (itype(i-1).le.ntyp) then
1914             iti1 = itortyp(itype(i-1))
1915           else
1916             iti1=ntortyp+1
1917           endif
1918         else
1919           iti1=ntortyp+1
1920         endif
1921 cd        write (iout,*) '*******i',i,' iti1',iti
1922 cd        write (iout,*) 'b1',b1(:,iti)
1923 cd        write (iout,*) 'b2',b2(:,iti)
1924 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1925 c        print *,"itilde1 i iti iti1",i,iti,iti1
1926         if (i .gt. iatel_s+2) then
1927           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1928           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1929           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1930           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1931           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1932           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1933           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1934         else
1935           do k=1,2
1936             Ub2(k,i-2)=0.0d0
1937             Ctobr(k,i-2)=0.0d0
1938             Dtobr2(k,i-2)=0.0d0
1939             do l=1,2
1940               EUg(l,k,i-2)=0.0d0
1941               CUg(l,k,i-2)=0.0d0
1942               DUg(l,k,i-2)=0.0d0
1943               DtUg2(l,k,i-2)=0.0d0
1944             enddo
1945           enddo
1946         endif
1947 c        print *,"itilde2 i iti iti1",i,iti,iti1
1948         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1949         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1950         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1951         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1952         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1953         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1954         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1955 c        print *,"itilde3 i iti iti1",i,iti,iti1
1956         do k=1,2
1957           muder(k,i-2)=Ub2der(k,i-2)
1958         enddo
1959         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1960           if (itype(i-1).le.ntyp) then
1961             iti1 = itortyp(itype(i-1))
1962           else
1963             iti1=ntortyp+1
1964           endif
1965         else
1966           iti1=ntortyp+1
1967         endif
1968         do k=1,2
1969           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1970         enddo
1971 C        write (iout,*) 'mumu',i,b1(1,iti),Ub2(1,i-2)
1972
1973 C Vectors and matrices dependent on a single virtual-bond dihedral.
1974         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1975         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1976         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1977         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1978         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1979         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1980         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1981         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1982         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1983 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1984 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1985       enddo
1986 C Matrices dependent on two consecutive virtual-bond dihedrals.
1987 C The order of matrices is from left to right.
1988       do i=2,nres-1
1989         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1990         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1991         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1992         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1993         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1994         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1995         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1996         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1997       enddo
1998 cd      do i=1,nres
1999 cd        iti = itortyp(itype(i))
2000 cd        write (iout,*) i
2001 cd        do j=1,2
2002 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2003 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2004 cd        enddo
2005 cd      enddo
2006       return
2007       end
2008 C--------------------------------------------------------------------------
2009       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2010 C
2011 C This subroutine calculates the average interaction energy and its gradient
2012 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2013 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2014 C The potential depends both on the distance of peptide-group centers and on
2015 C the orientation of the CA-CA virtual bonds.
2016 C
2017       implicit real*8 (a-h,o-z)
2018       include 'DIMENSIONS'
2019       include 'DIMENSIONS.ZSCOPT'
2020       include 'COMMON.CONTROL'
2021       include 'COMMON.IOUNITS'
2022       include 'COMMON.GEO'
2023       include 'COMMON.VAR'
2024       include 'COMMON.LOCAL'
2025       include 'COMMON.CHAIN'
2026       include 'COMMON.DERIV'
2027       include 'COMMON.INTERACT'
2028       include 'COMMON.CONTACTS'
2029       include 'COMMON.TORSION'
2030       include 'COMMON.VECTORS'
2031       include 'COMMON.FFIELD'
2032       include 'COMMON.SHIELD'
2033       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2034      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2035       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2036      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2037       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2038 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2039       double precision scal_el /0.5d0/
2040 C 12/13/98
2041 C 13-go grudnia roku pamietnego...
2042       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2043      &                   0.0d0,1.0d0,0.0d0,
2044      &                   0.0d0,0.0d0,1.0d0/
2045 cd      write(iout,*) 'In EELEC'
2046 cd      do i=1,nloctyp
2047 cd        write(iout,*) 'Type',i
2048 cd        write(iout,*) 'B1',B1(:,i)
2049 cd        write(iout,*) 'B2',B2(:,i)
2050 cd        write(iout,*) 'CC',CC(:,:,i)
2051 cd        write(iout,*) 'DD',DD(:,:,i)
2052 cd        write(iout,*) 'EE',EE(:,:,i)
2053 cd      enddo
2054 cd      call check_vecgrad
2055 cd      stop
2056       if (icheckgrad.eq.1) then
2057         do i=1,nres-1
2058           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2059           do k=1,3
2060             dc_norm(k,i)=dc(k,i)*fac
2061           enddo
2062 c          write (iout,*) 'i',i,' fac',fac
2063         enddo
2064       endif
2065       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2066      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2067      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2068 cd      if (wel_loc.gt.0.0d0) then
2069         if (icheckgrad.eq.1) then
2070         call vec_and_deriv_test
2071         else
2072         call vec_and_deriv
2073         endif
2074         call set_matrices
2075       endif
2076 cd      do i=1,nres-1
2077 cd        write (iout,*) 'i=',i
2078 cd        do k=1,3
2079 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2080 cd        enddo
2081 cd        do k=1,3
2082 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2083 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2084 cd        enddo
2085 cd      enddo
2086       num_conti_hb=0
2087       ees=0.0D0
2088       evdw1=0.0D0
2089       eel_loc=0.0d0
2090       eello_turn3=0.0d0
2091       eello_turn4=0.0d0
2092       ind=0
2093       do i=1,nres
2094         num_cont_hb(i)=0
2095       enddo
2096 C      print '(a)','Enter EELEC'
2097 C      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2098       do i=1,nres
2099         gel_loc_loc(i)=0.0d0
2100         gcorr_loc(i)=0.0d0
2101       enddo
2102       do i=iatel_s,iatel_e
2103 C          if (i.eq.1) then
2104            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2105 C     &  .or. itype(i+2).eq.ntyp1) cycle
2106 C          else
2107 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2108 C     &  .or. itype(i+2).eq.ntyp1
2109 C     &  .or. itype(i-1).eq.ntyp1
2110      &) cycle
2111 C         endif
2112         if (itel(i).eq.0) goto 1215
2113         dxi=dc(1,i)
2114         dyi=dc(2,i)
2115         dzi=dc(3,i)
2116         dx_normi=dc_norm(1,i)
2117         dy_normi=dc_norm(2,i)
2118         dz_normi=dc_norm(3,i)
2119         xmedi=c(1,i)+0.5d0*dxi
2120         ymedi=c(2,i)+0.5d0*dyi
2121         zmedi=c(3,i)+0.5d0*dzi
2122           xmedi=mod(xmedi,boxxsize)
2123           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2124           ymedi=mod(ymedi,boxysize)
2125           if (ymedi.lt.0) ymedi=ymedi+boxysize
2126           zmedi=mod(zmedi,boxzsize)
2127           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2128         num_conti=0
2129 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2130         do j=ielstart(i),ielend(i)
2131           if (j.le.1) cycle
2132 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2133 C     & .or.itype(j+2).eq.ntyp1
2134 C     &) cycle
2135 C          else
2136           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2137 C     & .or.itype(j+2).eq.ntyp1
2138 C     & .or.itype(j-1).eq.ntyp1
2139      &) cycle
2140 C         endif
2141 C
2142 C) cycle
2143           if (itel(j).eq.0) goto 1216
2144           ind=ind+1
2145           iteli=itel(i)
2146           itelj=itel(j)
2147           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2148           aaa=app(iteli,itelj)
2149           bbb=bpp(iteli,itelj)
2150 C Diagnostics only!!!
2151 c         aaa=0.0D0
2152 c         bbb=0.0D0
2153 c         ael6i=0.0D0
2154 c         ael3i=0.0D0
2155 C End diagnostics
2156           ael6i=ael6(iteli,itelj)
2157           ael3i=ael3(iteli,itelj)
2158           dxj=dc(1,j)
2159           dyj=dc(2,j)
2160           dzj=dc(3,j)
2161           dx_normj=dc_norm(1,j)
2162           dy_normj=dc_norm(2,j)
2163           dz_normj=dc_norm(3,j)
2164           xj=c(1,j)+0.5D0*dxj
2165           yj=c(2,j)+0.5D0*dyj
2166           zj=c(3,j)+0.5D0*dzj
2167          xj=mod(xj,boxxsize)
2168           if (xj.lt.0) xj=xj+boxxsize
2169           yj=mod(yj,boxysize)
2170           if (yj.lt.0) yj=yj+boxysize
2171           zj=mod(zj,boxzsize)
2172           if (zj.lt.0) zj=zj+boxzsize
2173       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2174       xj_safe=xj
2175       yj_safe=yj
2176       zj_safe=zj
2177       isubchap=0
2178       do xshift=-1,1
2179       do yshift=-1,1
2180       do zshift=-1,1
2181           xj=xj_safe+xshift*boxxsize
2182           yj=yj_safe+yshift*boxysize
2183           zj=zj_safe+zshift*boxzsize
2184           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2185           if(dist_temp.lt.dist_init) then
2186             dist_init=dist_temp
2187             xj_temp=xj
2188             yj_temp=yj
2189             zj_temp=zj
2190             isubchap=1
2191           endif
2192        enddo
2193        enddo
2194        enddo
2195        if (isubchap.eq.1) then
2196           xj=xj_temp-xmedi
2197           yj=yj_temp-ymedi
2198           zj=zj_temp-zmedi
2199        else
2200           xj=xj_safe-xmedi
2201           yj=yj_safe-ymedi
2202           zj=zj_safe-zmedi
2203        endif
2204           rij=xj*xj+yj*yj+zj*zj
2205             sss=sscale(sqrt(rij))
2206             sssgrad=sscagrad(sqrt(rij))
2207           rrmij=1.0D0/rij
2208           rij=dsqrt(rij)
2209           rmij=1.0D0/rij
2210           r3ij=rrmij*rmij
2211           r6ij=r3ij*r3ij
2212           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2213           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2214           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2215           fac=cosa-3.0D0*cosb*cosg
2216           ev1=aaa*r6ij*r6ij
2217 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2218           if (j.eq.i+2) ev1=scal_el*ev1
2219           ev2=bbb*r6ij
2220           fac3=ael6i*r6ij
2221           fac4=ael3i*r3ij
2222           evdwij=ev1+ev2
2223           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2224           el2=fac4*fac
2225           eesij=el1+el2
2226 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2227 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2228           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2229           if (shield_mode.gt.0) then
2230 C          fac_shield(i)=0.4
2231 C          fac_shield(j)=0.6
2232           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2233           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2234           eesij=(el1+el2)
2235           ees=ees+eesij
2236           else
2237           fac_shield(i)=1.0
2238           fac_shield(j)=1.0
2239           eesij=(el1+el2)
2240           ees=ees+eesij
2241           endif
2242           evdw1=evdw1+evdwij*sss
2243 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2244 c     &'evdw1',i,j,evdwij
2245 c     &,iteli,itelj,aaa,evdw1
2246
2247 C              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2248 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2249 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2250 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2251 c     &      xmedi,ymedi,zmedi,xj,yj,zj
2252 C
2253 C Calculate contributions to the Cartesian gradient.
2254 C
2255 #ifdef SPLITELE
2256           facvdw=-6*rrmij*(ev1+evdwij)*sss
2257           facel=-3*rrmij*(el1+eesij)
2258           fac1=fac
2259           erij(1)=xj*rmij
2260           erij(2)=yj*rmij
2261           erij(3)=zj*rmij
2262           if (calc_grad) then
2263 *
2264 * Radial derivatives. First process both termini of the fragment (i,j)
2265 *
2266           ggg(1)=facel*xj
2267           ggg(2)=facel*yj
2268           ggg(3)=facel*zj
2269           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2270      &  (shield_mode.gt.0)) then
2271 C          print *,i,j
2272           do ilist=1,ishield_list(i)
2273            iresshield=shield_list(ilist,i)
2274            do k=1,3
2275            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2276      &      *2.0
2277            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2278      &              rlocshield
2279      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2280             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2281 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2282 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2283 C             if (iresshield.gt.i) then
2284 C               do ishi=i+1,iresshield-1
2285 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2286 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2287 C
2288 C              enddo
2289 C             else
2290 C               do ishi=iresshield,i
2291 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2292 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2293 C
2294 C               enddo
2295 C              endif
2296            enddo
2297           enddo
2298           do ilist=1,ishield_list(j)
2299            iresshield=shield_list(ilist,j)
2300            do k=1,3
2301            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2302      &     *2.0
2303            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2304      &              rlocshield
2305      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2306            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2307            enddo
2308           enddo
2309
2310           do k=1,3
2311             gshieldc(k,i)=gshieldc(k,i)+
2312      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2313             gshieldc(k,j)=gshieldc(k,j)+
2314      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2315             gshieldc(k,i-1)=gshieldc(k,i-1)+
2316      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2317             gshieldc(k,j-1)=gshieldc(k,j-1)+
2318      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2319
2320            enddo
2321            endif
2322
2323           do k=1,3
2324             ghalf=0.5D0*ggg(k)
2325             gelc(k,i)=gelc(k,i)+ghalf
2326             gelc(k,j)=gelc(k,j)+ghalf
2327           enddo
2328 *
2329 * Loop over residues i+1 thru j-1.
2330 *
2331           do k=i+1,j-1
2332             do l=1,3
2333               gelc(l,k)=gelc(l,k)+ggg(l)
2334             enddo
2335           enddo
2336 C          ggg(1)=facvdw*xj
2337 C          ggg(2)=facvdw*yj
2338 C          ggg(3)=facvdw*zj
2339           if (sss.gt.0.0) then
2340           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2341           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2342           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2343           else
2344           ggg(1)=0.0
2345           ggg(2)=0.0
2346           ggg(3)=0.0
2347           endif
2348           do k=1,3
2349             ghalf=0.5D0*ggg(k)
2350             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2351             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2352           enddo
2353 *
2354 * Loop over residues i+1 thru j-1.
2355 *
2356           do k=i+1,j-1
2357             do l=1,3
2358               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2359             enddo
2360           enddo
2361 #else
2362           facvdw=(ev1+evdwij)*sss
2363           facel=el1+eesij
2364           fac1=fac
2365           fac=-3*rrmij*(facvdw+facvdw+facel)
2366           erij(1)=xj*rmij
2367           erij(2)=yj*rmij
2368           erij(3)=zj*rmij
2369           if (calc_grad) then
2370 *
2371 * Radial derivatives. First process both termini of the fragment (i,j)
2372 *
2373           ggg(1)=fac*xj
2374           ggg(2)=fac*yj
2375           ggg(3)=fac*zj
2376           do k=1,3
2377             ghalf=0.5D0*ggg(k)
2378             gelc(k,i)=gelc(k,i)+ghalf
2379             gelc(k,j)=gelc(k,j)+ghalf
2380           enddo
2381 *
2382 * Loop over residues i+1 thru j-1.
2383 *
2384           do k=i+1,j-1
2385             do l=1,3
2386               gelc(l,k)=gelc(l,k)+ggg(l)
2387             enddo
2388           enddo
2389 #endif
2390 *
2391 * Angular part
2392 *
2393           ecosa=2.0D0*fac3*fac1+fac4
2394           fac4=-3.0D0*fac4
2395           fac3=-6.0D0*fac3
2396           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2397           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2398           do k=1,3
2399             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2400             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2401           enddo
2402 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2403 cd   &          (dcosg(k),k=1,3)
2404           do k=1,3
2405             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2406      &      *fac_shield(i)**2*fac_shield(j)**2
2407           enddo
2408           do k=1,3
2409             ghalf=0.5D0*ggg(k)
2410             gelc(k,i)=gelc(k,i)+ghalf
2411      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2412      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2413      &           *fac_shield(i)**2*fac_shield(j)**2
2414
2415             gelc(k,j)=gelc(k,j)+ghalf
2416      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2417      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2418      &           *fac_shield(i)**2*fac_shield(j)**2
2419           enddo
2420           do k=i+1,j-1
2421             do l=1,3
2422               gelc(l,k)=gelc(l,k)+ggg(l)
2423             enddo
2424           enddo
2425           endif
2426
2427           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2428      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2429      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2430 C
2431 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2432 C   energy of a peptide unit is assumed in the form of a second-order
2433 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2434 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2435 C   are computed for EVERY pair of non-contiguous peptide groups.
2436 C
2437           if (j.lt.nres-1) then
2438             j1=j+1
2439             j2=j-1
2440           else
2441             j1=j-1
2442             j2=j-2
2443           endif
2444           kkk=0
2445           do k=1,2
2446             do l=1,2
2447               kkk=kkk+1
2448               muij(kkk)=mu(k,i)*mu(l,j)
2449             enddo
2450           enddo
2451 cd         write (iout,*) 'EELEC: i',i,' j',j
2452 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2453 cd          write(iout,*) 'muij',muij
2454           ury=scalar(uy(1,i),erij)
2455           urz=scalar(uz(1,i),erij)
2456           vry=scalar(uy(1,j),erij)
2457           vrz=scalar(uz(1,j),erij)
2458           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2459           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2460           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2461           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2462 C For diagnostics only
2463 cd          a22=1.0d0
2464 cd          a23=1.0d0
2465 cd          a32=1.0d0
2466 cd          a33=1.0d0
2467           fac=dsqrt(-ael6i)*r3ij
2468 cd          write (2,*) 'fac=',fac
2469 C For diagnostics only
2470 cd          fac=1.0d0
2471           a22=a22*fac
2472           a23=a23*fac
2473           a32=a32*fac
2474           a33=a33*fac
2475 cd          write (iout,'(4i5,4f10.5)')
2476 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2477 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2478 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2479 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2480 cd          write (iout,'(4f10.5)')
2481 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2482 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2483 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2484 cd           write (iout,'(2i3,9f10.5/)') i,j,
2485 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2486           if (calc_grad) then
2487 C Derivatives of the elements of A in virtual-bond vectors
2488           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2489 cd          do k=1,3
2490 cd            do l=1,3
2491 cd              erder(k,l)=0.0d0
2492 cd            enddo
2493 cd          enddo
2494           do k=1,3
2495             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2496             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2497             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2498             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2499             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2500             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2501             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2502             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2503             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2504             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2505             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2506             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2507           enddo
2508 cd          do k=1,3
2509 cd            do l=1,3
2510 cd              uryg(k,l)=0.0d0
2511 cd              urzg(k,l)=0.0d0
2512 cd              vryg(k,l)=0.0d0
2513 cd              vrzg(k,l)=0.0d0
2514 cd            enddo
2515 cd          enddo
2516 C Compute radial contributions to the gradient
2517           facr=-3.0d0*rrmij
2518           a22der=a22*facr
2519           a23der=a23*facr
2520           a32der=a32*facr
2521           a33der=a33*facr
2522 cd          a22der=0.0d0
2523 cd          a23der=0.0d0
2524 cd          a32der=0.0d0
2525 cd          a33der=0.0d0
2526           agg(1,1)=a22der*xj
2527           agg(2,1)=a22der*yj
2528           agg(3,1)=a22der*zj
2529           agg(1,2)=a23der*xj
2530           agg(2,2)=a23der*yj
2531           agg(3,2)=a23der*zj
2532           agg(1,3)=a32der*xj
2533           agg(2,3)=a32der*yj
2534           agg(3,3)=a32der*zj
2535           agg(1,4)=a33der*xj
2536           agg(2,4)=a33der*yj
2537           agg(3,4)=a33der*zj
2538 C Add the contributions coming from er
2539           fac3=-3.0d0*fac
2540           do k=1,3
2541             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2542             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2543             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2544             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2545           enddo
2546           do k=1,3
2547 C Derivatives in DC(i)
2548             ghalf1=0.5d0*agg(k,1)
2549             ghalf2=0.5d0*agg(k,2)
2550             ghalf3=0.5d0*agg(k,3)
2551             ghalf4=0.5d0*agg(k,4)
2552             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2553      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2554             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2555      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2556             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2557      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2558             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2559      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2560 C Derivatives in DC(i+1)
2561             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2562      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2563             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2564      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2565             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2566      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2567             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2568      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2569 C Derivatives in DC(j)
2570             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2571      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2572             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2573      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2574             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2575      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2576             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2577      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2578 C Derivatives in DC(j+1) or DC(nres-1)
2579             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2580      &      -3.0d0*vryg(k,3)*ury)
2581             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2582      &      -3.0d0*vrzg(k,3)*ury)
2583             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2584      &      -3.0d0*vryg(k,3)*urz)
2585             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2586      &      -3.0d0*vrzg(k,3)*urz)
2587 cd            aggi(k,1)=ghalf1
2588 cd            aggi(k,2)=ghalf2
2589 cd            aggi(k,3)=ghalf3
2590 cd            aggi(k,4)=ghalf4
2591 C Derivatives in DC(i+1)
2592 cd            aggi1(k,1)=agg(k,1)
2593 cd            aggi1(k,2)=agg(k,2)
2594 cd            aggi1(k,3)=agg(k,3)
2595 cd            aggi1(k,4)=agg(k,4)
2596 C Derivatives in DC(j)
2597 cd            aggj(k,1)=ghalf1
2598 cd            aggj(k,2)=ghalf2
2599 cd            aggj(k,3)=ghalf3
2600 cd            aggj(k,4)=ghalf4
2601 C Derivatives in DC(j+1)
2602 cd            aggj1(k,1)=0.0d0
2603 cd            aggj1(k,2)=0.0d0
2604 cd            aggj1(k,3)=0.0d0
2605 cd            aggj1(k,4)=0.0d0
2606             if (j.eq.nres-1 .and. i.lt.j-2) then
2607               do l=1,4
2608                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2609 cd                aggj1(k,l)=agg(k,l)
2610               enddo
2611             endif
2612           enddo
2613           endif
2614 c          goto 11111
2615 C Check the loc-el terms by numerical integration
2616           acipa(1,1)=a22
2617           acipa(1,2)=a23
2618           acipa(2,1)=a32
2619           acipa(2,2)=a33
2620           a22=-a22
2621           a23=-a23
2622           do l=1,2
2623             do k=1,3
2624               agg(k,l)=-agg(k,l)
2625               aggi(k,l)=-aggi(k,l)
2626               aggi1(k,l)=-aggi1(k,l)
2627               aggj(k,l)=-aggj(k,l)
2628               aggj1(k,l)=-aggj1(k,l)
2629             enddo
2630           enddo
2631           if (j.lt.nres-1) then
2632             a22=-a22
2633             a32=-a32
2634             do l=1,3,2
2635               do k=1,3
2636                 agg(k,l)=-agg(k,l)
2637                 aggi(k,l)=-aggi(k,l)
2638                 aggi1(k,l)=-aggi1(k,l)
2639                 aggj(k,l)=-aggj(k,l)
2640                 aggj1(k,l)=-aggj1(k,l)
2641               enddo
2642             enddo
2643           else
2644             a22=-a22
2645             a23=-a23
2646             a32=-a32
2647             a33=-a33
2648             do l=1,4
2649               do k=1,3
2650                 agg(k,l)=-agg(k,l)
2651                 aggi(k,l)=-aggi(k,l)
2652                 aggi1(k,l)=-aggi1(k,l)
2653                 aggj(k,l)=-aggj(k,l)
2654                 aggj1(k,l)=-aggj1(k,l)
2655               enddo
2656             enddo
2657           endif
2658           ENDIF ! WCORR
2659 11111     continue
2660           IF (wel_loc.gt.0.0d0) THEN
2661 C Contribution to the local-electrostatic energy coming from the i-j pair
2662           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2663      &     +a33*muij(4)
2664           if (shield_mode.eq.0) then
2665            fac_shield(i)=1.0
2666            fac_shield(j)=1.0
2667 C          else
2668 C           fac_shield(i)=0.4
2669 C           fac_shield(j)=0.6
2670           endif
2671           eel_loc_ij=eel_loc_ij
2672      &    *fac_shield(i)*fac_shield(j)
2673 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2674 C          write (iout,'(a6,2i5,0pf7.3)')
2675 C     &            'eelloc',i,j,eel_loc_ij
2676 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2677 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2678 C          eel_loc=eel_loc+eel_loc_ij
2679           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2680      &  (shield_mode.gt.0)) then
2681 C          print *,i,j
2682
2683           do ilist=1,ishield_list(i)
2684            iresshield=shield_list(ilist,i)
2685            do k=1,3
2686            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2687      &                                          /fac_shield(i)
2688 C     &      *2.0
2689            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2690      &              rlocshield
2691      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2692             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2693      &      +rlocshield
2694            enddo
2695           enddo
2696           do ilist=1,ishield_list(j)
2697            iresshield=shield_list(ilist,j)
2698            do k=1,3
2699            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2700      &                                       /fac_shield(j)
2701 C     &     *2.0
2702            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2703      &              rlocshield
2704      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2705            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2706      &             +rlocshield
2707
2708            enddo
2709           enddo
2710           do k=1,3
2711             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2712      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2713             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2714      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2715             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2716      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2717             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2718      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2719            enddo
2720            endif
2721           eel_loc=eel_loc+eel_loc_ij
2722
2723 C Partial derivatives in virtual-bond dihedral angles gamma
2724           if (calc_grad) then
2725           if (i.gt.1)
2726      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2727      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2728      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
2729      &    *fac_shield(i)*fac_shield(j)
2730
2731           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2732      &            (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2733      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
2734      &    *fac_shield(i)*fac_shield(j)
2735
2736 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2737 cd          write(iout,*) 'agg  ',agg
2738 cd          write(iout,*) 'aggi ',aggi
2739 cd          write(iout,*) 'aggi1',aggi1
2740 cd          write(iout,*) 'aggj ',aggj
2741 cd          write(iout,*) 'aggj1',aggj1
2742
2743 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2744           do l=1,3
2745             ggg(l)=(agg(l,1)*muij(1)+
2746      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
2747      &    *fac_shield(i)*fac_shield(j)
2748
2749           enddo
2750           do k=i+2,j2
2751             do l=1,3
2752               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2753             enddo
2754           enddo
2755 C Remaining derivatives of eello
2756           do l=1,3
2757             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
2758      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
2759      &    *fac_shield(i)*fac_shield(j)
2760
2761             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
2762      &         aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
2763      &    *fac_shield(i)*fac_shield(j)
2764
2765             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
2766      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
2767      &    *fac_shield(i)*fac_shield(j)
2768
2769             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
2770      &         aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
2771      &    *fac_shield(i)*fac_shield(j)
2772
2773           enddo
2774           endif
2775           ENDIF
2776           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2777 C Contributions from turns
2778             a_temp(1,1)=a22
2779             a_temp(1,2)=a23
2780             a_temp(2,1)=a32
2781             a_temp(2,2)=a33
2782             call eturn34(i,j,eello_turn3,eello_turn4)
2783           endif
2784 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2785           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2786 C
2787 C Calculate the contact function. The ith column of the array JCONT will
2788 C contain the numbers of atoms that make contacts with the atom I (of numbers
2789 C greater than I). The arrays FACONT and GACONT will contain the values of
2790 C the contact function and its derivative.
2791 c           r0ij=1.02D0*rpp(iteli,itelj)
2792 c           r0ij=1.11D0*rpp(iteli,itelj)
2793             r0ij=2.20D0*rpp(iteli,itelj)
2794 c           r0ij=1.55D0*rpp(iteli,itelj)
2795             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2796             if (fcont.gt.0.0D0) then
2797               num_conti=num_conti+1
2798               if (num_conti.gt.maxconts) then
2799                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2800      &                         ' will skip next contacts for this conf.'
2801               else
2802                 jcont_hb(num_conti,i)=j
2803                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2804      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2805 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2806 C  terms.
2807                 d_cont(num_conti,i)=rij
2808 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2809 C     --- Electrostatic-interaction matrix ---
2810                 a_chuj(1,1,num_conti,i)=a22
2811                 a_chuj(1,2,num_conti,i)=a23
2812                 a_chuj(2,1,num_conti,i)=a32
2813                 a_chuj(2,2,num_conti,i)=a33
2814 C     --- Gradient of rij
2815                 do kkk=1,3
2816                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2817                 enddo
2818 c             if (i.eq.1) then
2819 c                a_chuj(1,1,num_conti,i)=-0.61d0
2820 c                a_chuj(1,2,num_conti,i)= 0.4d0
2821 c                a_chuj(2,1,num_conti,i)= 0.65d0
2822 c                a_chuj(2,2,num_conti,i)= 0.50d0
2823 c             else if (i.eq.2) then
2824 c                a_chuj(1,1,num_conti,i)= 0.0d0
2825 c                a_chuj(1,2,num_conti,i)= 0.0d0
2826 c                a_chuj(2,1,num_conti,i)= 0.0d0
2827 c                a_chuj(2,2,num_conti,i)= 0.0d0
2828 c             endif
2829 C     --- and its gradients
2830 cd                write (iout,*) 'i',i,' j',j
2831 cd                do kkk=1,3
2832 cd                write (iout,*) 'iii 1 kkk',kkk
2833 cd                write (iout,*) agg(kkk,:)
2834 cd                enddo
2835 cd                do kkk=1,3
2836 cd                write (iout,*) 'iii 2 kkk',kkk
2837 cd                write (iout,*) aggi(kkk,:)
2838 cd                enddo
2839 cd                do kkk=1,3
2840 cd                write (iout,*) 'iii 3 kkk',kkk
2841 cd                write (iout,*) aggi1(kkk,:)
2842 cd                enddo
2843 cd                do kkk=1,3
2844 cd                write (iout,*) 'iii 4 kkk',kkk
2845 cd                write (iout,*) aggj(kkk,:)
2846 cd                enddo
2847 cd                do kkk=1,3
2848 cd                write (iout,*) 'iii 5 kkk',kkk
2849 cd                write (iout,*) aggj1(kkk,:)
2850 cd                enddo
2851                 kkll=0
2852                 do k=1,2
2853                   do l=1,2
2854                     kkll=kkll+1
2855                     do m=1,3
2856                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2857                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2858                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2859                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2860                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2861 c                      do mm=1,5
2862 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2863 c                      enddo
2864                     enddo
2865                   enddo
2866                 enddo
2867                 ENDIF
2868                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2869 C Calculate contact energies
2870                 cosa4=4.0D0*cosa
2871                 wij=cosa-3.0D0*cosb*cosg
2872                 cosbg1=cosb+cosg
2873                 cosbg2=cosb-cosg
2874 c               fac3=dsqrt(-ael6i)/r0ij**3
2875                 fac3=dsqrt(-ael6i)*r3ij
2876                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2877                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2878 c               ees0mij=0.0D0
2879                 if (shield_mode.eq.0) then
2880                 fac_shield(i)=1.0d0
2881                 fac_shield(j)=1.0d0
2882                 else
2883                 ees0plist(num_conti,i)=j
2884 C                fac_shield(i)=0.4d0
2885 C                fac_shield(j)=0.6d0
2886                 endif
2887                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2888      &          *fac_shield(i)*fac_shield(j)
2889
2890                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2891      &          *fac_shield(i)*fac_shield(j)
2892
2893 C Diagnostics. Comment out or remove after debugging!
2894 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2895 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2896 c               ees0m(num_conti,i)=0.0D0
2897 C End diagnostics.
2898 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2899 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2900                 facont_hb(num_conti,i)=fcont
2901                 if (calc_grad) then
2902 C Angular derivatives of the contact function
2903                 ees0pij1=fac3/ees0pij
2904                 ees0mij1=fac3/ees0mij
2905                 fac3p=-3.0D0*fac3*rrmij
2906                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2907                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2908 c               ees0mij1=0.0D0
2909                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2910                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2911                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2912                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2913                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2914                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2915                 ecosap=ecosa1+ecosa2
2916                 ecosbp=ecosb1+ecosb2
2917                 ecosgp=ecosg1+ecosg2
2918                 ecosam=ecosa1-ecosa2
2919                 ecosbm=ecosb1-ecosb2
2920                 ecosgm=ecosg1-ecosg2
2921 C Diagnostics
2922 c               ecosap=ecosa1
2923 c               ecosbp=ecosb1
2924 c               ecosgp=ecosg1
2925 c               ecosam=0.0D0
2926 c               ecosbm=0.0D0
2927 c               ecosgm=0.0D0
2928 C End diagnostics
2929                 fprimcont=fprimcont/rij
2930 cd              facont_hb(num_conti,i)=1.0D0
2931 C Following line is for diagnostics.
2932 cd              fprimcont=0.0D0
2933                 do k=1,3
2934                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2935                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2936                 enddo
2937                 do k=1,3
2938                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2939                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2940                 enddo
2941                 gggp(1)=gggp(1)+ees0pijp*xj
2942                 gggp(2)=gggp(2)+ees0pijp*yj
2943                 gggp(3)=gggp(3)+ees0pijp*zj
2944                 gggm(1)=gggm(1)+ees0mijp*xj
2945                 gggm(2)=gggm(2)+ees0mijp*yj
2946                 gggm(3)=gggm(3)+ees0mijp*zj
2947 C Derivatives due to the contact function
2948                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2949                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2950                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2951                 do k=1,3
2952                   ghalfp=0.5D0*gggp(k)
2953                   ghalfm=0.5D0*gggm(k)
2954                   gacontp_hb1(k,num_conti,i)=ghalfp
2955      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2956      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2957      &          *fac_shield(i)*fac_shield(j)
2958
2959                   gacontp_hb2(k,num_conti,i)=ghalfp
2960      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2961      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2962      &          *fac_shield(i)*fac_shield(j)
2963
2964                   gacontp_hb3(k,num_conti,i)=gggp(k)
2965                   gacontm_hb1(k,num_conti,i)=ghalfm
2966      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2967      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2968      &          *fac_shield(i)*fac_shield(j)
2969
2970                   gacontm_hb2(k,num_conti,i)=ghalfm
2971      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2972      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2973      &          *fac_shield(i)*fac_shield(j)
2974
2975                   gacontm_hb3(k,num_conti,i)=gggm(k)
2976      &          *fac_shield(i)*fac_shield(j)
2977
2978                 enddo
2979                 endif
2980 C Diagnostics. Comment out or remove after debugging!
2981 cdiag           do k=1,3
2982 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2983 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2984 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2985 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2986 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2987 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2988 cdiag           enddo
2989               ENDIF ! wcorr
2990               endif  ! num_conti.le.maxconts
2991             endif  ! fcont.gt.0
2992           endif    ! j.gt.i+1
2993  1216     continue
2994         enddo ! j
2995         num_cont_hb(i)=num_conti
2996  1215   continue
2997       enddo   ! i
2998 cd      do i=1,nres
2999 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3000 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3001 cd      enddo
3002 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3003 ccc      eel_loc=eel_loc+eello_turn3
3004       return
3005       end
3006 C-----------------------------------------------------------------------------
3007       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3008 C Third- and fourth-order contributions from turns
3009       implicit real*8 (a-h,o-z)
3010       include 'DIMENSIONS'
3011       include 'DIMENSIONS.ZSCOPT'
3012       include 'COMMON.IOUNITS'
3013       include 'COMMON.GEO'
3014       include 'COMMON.VAR'
3015       include 'COMMON.LOCAL'
3016       include 'COMMON.CHAIN'
3017       include 'COMMON.DERIV'
3018       include 'COMMON.INTERACT'
3019       include 'COMMON.CONTACTS'
3020       include 'COMMON.TORSION'
3021       include 'COMMON.VECTORS'
3022       include 'COMMON.FFIELD'
3023       include 'COMMON.SHIELD'
3024       include 'COMMON.CONTROL'
3025       dimension ggg(3)
3026       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3027      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3028      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3029       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3030      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3031       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3032       if (j.eq.i+2) then
3033       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3034 C changes suggested by Ana to avoid out of bounds
3035 C     & .or.((i+5).gt.nres)
3036 C     & .or.((i-1).le.0)
3037 C end of changes suggested by Ana
3038      &    .or. itype(i+2).eq.ntyp1
3039      &    .or. itype(i+3).eq.ntyp1
3040 C     &    .or. itype(i+5).eq.ntyp1
3041 C     &    .or. itype(i).eq.ntyp1
3042 C     &    .or. itype(i-1).eq.ntyp1
3043      &    ) goto 178
3044
3045 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3046 C
3047 C               Third-order contributions
3048 C
3049 C                 (i+2)o----(i+3)
3050 C                      | |
3051 C                      | |
3052 C                 (i+1)o----i
3053 C
3054 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3055 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3056         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3057         call transpose2(auxmat(1,1),auxmat1(1,1))
3058         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3059         if (shield_mode.eq.0) then
3060         fac_shield(i)=1.0
3061         fac_shield(j)=1.0
3062 C        else
3063 C        fac_shield(i)=0.4
3064 C        fac_shield(j)=0.6
3065         endif
3066
3067         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3068      &  *fac_shield(i)*fac_shield(j)
3069         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3070      &  *fac_shield(i)*fac_shield(j)
3071
3072 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3073 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3074 cd     &    ' eello_turn3_num',4*eello_turn3_num
3075         if (calc_grad) then
3076 C Derivatives in shield mode
3077           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3078      &  (shield_mode.gt.0)) then
3079 C          print *,i,j
3080
3081           do ilist=1,ishield_list(i)
3082            iresshield=shield_list(ilist,i)
3083            do k=1,3
3084            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3085 C     &      *2.0
3086            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3087      &              rlocshield
3088      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3089             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3090      &      +rlocshield
3091            enddo
3092           enddo
3093           do ilist=1,ishield_list(j)
3094            iresshield=shield_list(ilist,j)
3095            do k=1,3
3096            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3097 C     &     *2.0
3098            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3099      &              rlocshield
3100      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3101            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3102      &             +rlocshield
3103
3104            enddo
3105           enddo
3106
3107           do k=1,3
3108             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3109      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3110             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3111      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3112             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3113      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3114             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3115      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3116            enddo
3117            endif
3118
3119 C Derivatives in gamma(i)
3120         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3121         call transpose2(auxmat2(1,1),pizda(1,1))
3122         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3123         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3124 C Derivatives in gamma(i+1)
3125         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3126         call transpose2(auxmat2(1,1),pizda(1,1))
3127         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3128         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3129      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3130      &   *fac_shield(i)*fac_shield(j)
3131
3132 C Cartesian derivatives
3133         do l=1,3
3134           a_temp(1,1)=aggi(l,1)
3135           a_temp(1,2)=aggi(l,2)
3136           a_temp(2,1)=aggi(l,3)
3137           a_temp(2,2)=aggi(l,4)
3138           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3139           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3140      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3141      &   *fac_shield(i)*fac_shield(j)
3142
3143           a_temp(1,1)=aggi1(l,1)
3144           a_temp(1,2)=aggi1(l,2)
3145           a_temp(2,1)=aggi1(l,3)
3146           a_temp(2,2)=aggi1(l,4)
3147           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3148           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3149      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3150      &   *fac_shield(i)*fac_shield(j)
3151
3152           a_temp(1,1)=aggj(l,1)
3153           a_temp(1,2)=aggj(l,2)
3154           a_temp(2,1)=aggj(l,3)
3155           a_temp(2,2)=aggj(l,4)
3156           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3157           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3158      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3159      &   *fac_shield(i)*fac_shield(j)
3160
3161           a_temp(1,1)=aggj1(l,1)
3162           a_temp(1,2)=aggj1(l,2)
3163           a_temp(2,1)=aggj1(l,3)
3164           a_temp(2,2)=aggj1(l,4)
3165           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3166           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3167      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3168      &   *fac_shield(i)*fac_shield(j)
3169
3170         enddo
3171         endif
3172       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3173       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3174 C changes suggested by Ana to avoid out of bounds
3175 C     & .or.((i+5).gt.nres)
3176 C     & .or.((i-1).le.0)
3177 C end of changes suggested by Ana
3178      &    .or. itype(i+3).eq.ntyp1
3179      &    .or. itype(i+4).eq.ntyp1
3180 C     &    .or. itype(i+5).eq.ntyp1
3181      &    .or. itype(i).eq.ntyp1
3182 C     &    .or. itype(i-1).eq.ntyp1
3183      &    ) goto 178
3184 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3185 C
3186 C               Fourth-order contributions
3187 C
3188 C                 (i+3)o----(i+4)
3189 C                     /  |
3190 C               (i+2)o   |
3191 C                     \  |
3192 C                 (i+1)o----i
3193 C
3194 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3195 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3196         iti1=itortyp(itype(i+1))
3197         iti2=itortyp(itype(i+2))
3198         iti3=itortyp(itype(i+3))
3199         call transpose2(EUg(1,1,i+1),e1t(1,1))
3200         call transpose2(Eug(1,1,i+2),e2t(1,1))
3201         call transpose2(Eug(1,1,i+3),e3t(1,1))
3202         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3203         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3204         s1=scalar2(b1(1,iti2),auxvec(1))
3205         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3206         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3207         s2=scalar2(b1(1,iti1),auxvec(1))
3208         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3209         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3210         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3211         if (shield_mode.eq.0) then
3212         fac_shield(i)=1.0
3213         fac_shield(j)=1.0
3214 C        else
3215 C        fac_shield(i)=0.4
3216 C        fac_shield(j)=0.6
3217         endif
3218
3219         eello_turn4=eello_turn4-(s1+s2+s3)
3220      &  *fac_shield(i)*fac_shield(j)
3221         eello_t4=-(s1+s2+s3)
3222      &  *fac_shield(i)*fac_shield(j)
3223
3224 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3225 cd     &    ' eello_turn4_num',8*eello_turn4_num
3226 C Derivatives in gamma(i)
3227         if (calc_grad) then
3228           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3229      &  (shield_mode.gt.0)) then
3230 C          print *,i,j
3231
3232           do ilist=1,ishield_list(i)
3233            iresshield=shield_list(ilist,i)
3234            do k=1,3
3235            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3236 C     &      *2.0
3237            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3238      &              rlocshield
3239      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3240             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3241      &      +rlocshield
3242            enddo
3243           enddo
3244           do ilist=1,ishield_list(j)
3245            iresshield=shield_list(ilist,j)
3246            do k=1,3
3247            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3248 C     &     *2.0
3249            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3250      &              rlocshield
3251      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3252            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3253      &             +rlocshield
3254
3255            enddo
3256           enddo
3257
3258           do k=1,3
3259             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3260      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3261             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3262      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3263             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3264      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3265             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3266      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3267            enddo
3268            endif
3269         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3270         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3271         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3272         s1=scalar2(b1(1,iti2),auxvec(1))
3273         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3274         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3275         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3276      &  *fac_shield(i)*fac_shield(j)
3277
3278 C Derivatives in gamma(i+1)
3279         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3280         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3281         s2=scalar2(b1(1,iti1),auxvec(1))
3282         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3283         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3284         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3285         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3286      &  *fac_shield(i)*fac_shield(j)
3287
3288 C Derivatives in gamma(i+2)
3289         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3290         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3291         s1=scalar2(b1(1,iti2),auxvec(1))
3292         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3293         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3294         s2=scalar2(b1(1,iti1),auxvec(1))
3295         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3296         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3297         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3298         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3299      &  *fac_shield(i)*fac_shield(j)
3300
3301 C Cartesian derivatives
3302
3303 C Derivatives of this turn contributions in DC(i+2)
3304         if (j.lt.nres-1) then
3305           do l=1,3
3306             a_temp(1,1)=agg(l,1)
3307             a_temp(1,2)=agg(l,2)
3308             a_temp(2,1)=agg(l,3)
3309             a_temp(2,2)=agg(l,4)
3310             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3311             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3312             s1=scalar2(b1(1,iti2),auxvec(1))
3313             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3314             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3315             s2=scalar2(b1(1,iti1),auxvec(1))
3316             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3317             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3318             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3319             ggg(l)=-(s1+s2+s3)
3320             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3321      &  *fac_shield(i)*fac_shield(j)
3322
3323           enddo
3324         endif
3325 C Remaining derivatives of this turn contribution
3326         do l=1,3
3327           a_temp(1,1)=aggi(l,1)
3328           a_temp(1,2)=aggi(l,2)
3329           a_temp(2,1)=aggi(l,3)
3330           a_temp(2,2)=aggi(l,4)
3331           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3332           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3333           s1=scalar2(b1(1,iti2),auxvec(1))
3334           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3335           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3336           s2=scalar2(b1(1,iti1),auxvec(1))
3337           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3338           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3339           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3340           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3341      &  *fac_shield(i)*fac_shield(j)
3342
3343           a_temp(1,1)=aggi1(l,1)
3344           a_temp(1,2)=aggi1(l,2)
3345           a_temp(2,1)=aggi1(l,3)
3346           a_temp(2,2)=aggi1(l,4)
3347           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3348           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3349           s1=scalar2(b1(1,iti2),auxvec(1))
3350           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3351           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3352           s2=scalar2(b1(1,iti1),auxvec(1))
3353           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3354           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3355           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3356           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3357      &  *fac_shield(i)*fac_shield(j)
3358
3359           a_temp(1,1)=aggj(l,1)
3360           a_temp(1,2)=aggj(l,2)
3361           a_temp(2,1)=aggj(l,3)
3362           a_temp(2,2)=aggj(l,4)
3363           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3364           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3365           s1=scalar2(b1(1,iti2),auxvec(1))
3366           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3367           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3368           s2=scalar2(b1(1,iti1),auxvec(1))
3369           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3370           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3371           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3372           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3373      &  *fac_shield(i)*fac_shield(j)
3374
3375           a_temp(1,1)=aggj1(l,1)
3376           a_temp(1,2)=aggj1(l,2)
3377           a_temp(2,1)=aggj1(l,3)
3378           a_temp(2,2)=aggj1(l,4)
3379           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3380           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3381           s1=scalar2(b1(1,iti2),auxvec(1))
3382           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3383           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3384           s2=scalar2(b1(1,iti1),auxvec(1))
3385           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3386           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3387           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3388           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3389      &  *fac_shield(i)*fac_shield(j)
3390
3391         enddo
3392         endif
3393  178  continue
3394       endif
3395       return
3396       end
3397 C-----------------------------------------------------------------------------
3398       subroutine vecpr(u,v,w)
3399       implicit real*8(a-h,o-z)
3400       dimension u(3),v(3),w(3)
3401       w(1)=u(2)*v(3)-u(3)*v(2)
3402       w(2)=-u(1)*v(3)+u(3)*v(1)
3403       w(3)=u(1)*v(2)-u(2)*v(1)
3404       return
3405       end
3406 C-----------------------------------------------------------------------------
3407       subroutine unormderiv(u,ugrad,unorm,ungrad)
3408 C This subroutine computes the derivatives of a normalized vector u, given
3409 C the derivatives computed without normalization conditions, ugrad. Returns
3410 C ungrad.
3411       implicit none
3412       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3413       double precision vec(3)
3414       double precision scalar
3415       integer i,j
3416 c      write (2,*) 'ugrad',ugrad
3417 c      write (2,*) 'u',u
3418       do i=1,3
3419         vec(i)=scalar(ugrad(1,i),u(1))
3420       enddo
3421 c      write (2,*) 'vec',vec
3422       do i=1,3
3423         do j=1,3
3424           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3425         enddo
3426       enddo
3427 c      write (2,*) 'ungrad',ungrad
3428       return
3429       end
3430 C-----------------------------------------------------------------------------
3431       subroutine escp(evdw2,evdw2_14)
3432 C
3433 C This subroutine calculates the excluded-volume interaction energy between
3434 C peptide-group centers and side chains and its gradient in virtual-bond and
3435 C side-chain vectors.
3436 C
3437       implicit real*8 (a-h,o-z)
3438       include 'DIMENSIONS'
3439       include 'DIMENSIONS.ZSCOPT'
3440       include 'COMMON.GEO'
3441       include 'COMMON.VAR'
3442       include 'COMMON.LOCAL'
3443       include 'COMMON.CHAIN'
3444       include 'COMMON.DERIV'
3445       include 'COMMON.INTERACT'
3446       include 'COMMON.FFIELD'
3447       include 'COMMON.IOUNITS'
3448       dimension ggg(3)
3449       evdw2=0.0D0
3450       evdw2_14=0.0d0
3451 cd    print '(a)','Enter ESCP'
3452 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3453 c     &  ' scal14',scal14
3454       do i=iatscp_s,iatscp_e
3455         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3456         iteli=itel(i)
3457 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3458 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3459         if (iteli.eq.0) goto 1225
3460         xi=0.5D0*(c(1,i)+c(1,i+1))
3461         yi=0.5D0*(c(2,i)+c(2,i+1))
3462         zi=0.5D0*(c(3,i)+c(3,i+1))
3463 C Returning the ith atom to box
3464           xi=mod(xi,boxxsize)
3465           if (xi.lt.0) xi=xi+boxxsize
3466           yi=mod(yi,boxysize)
3467           if (yi.lt.0) yi=yi+boxysize
3468           zi=mod(zi,boxzsize)
3469           if (zi.lt.0) zi=zi+boxzsize
3470         do iint=1,nscp_gr(i)
3471
3472         do j=iscpstart(i,iint),iscpend(i,iint)
3473           itypj=iabs(itype(j))
3474           if (itypj.eq.ntyp1) cycle
3475 C Uncomment following three lines for SC-p interactions
3476 c         xj=c(1,nres+j)-xi
3477 c         yj=c(2,nres+j)-yi
3478 c         zj=c(3,nres+j)-zi
3479 C Uncomment following three lines for Ca-p interactions
3480           xj=c(1,j)
3481           yj=c(2,j)
3482           zj=c(3,j)
3483 C returning the jth atom to box
3484           xj=mod(xj,boxxsize)
3485           if (xj.lt.0) xj=xj+boxxsize
3486           yj=mod(yj,boxysize)
3487           if (yj.lt.0) yj=yj+boxysize
3488           zj=mod(zj,boxzsize)
3489           if (zj.lt.0) zj=zj+boxzsize
3490       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3491       xj_safe=xj
3492       yj_safe=yj
3493       zj_safe=zj
3494       subchap=0
3495 C Finding the closest jth atom
3496       do xshift=-1,1
3497       do yshift=-1,1
3498       do zshift=-1,1
3499           xj=xj_safe+xshift*boxxsize
3500           yj=yj_safe+yshift*boxysize
3501           zj=zj_safe+zshift*boxzsize
3502           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3503           if(dist_temp.lt.dist_init) then
3504             dist_init=dist_temp
3505             xj_temp=xj
3506             yj_temp=yj
3507             zj_temp=zj
3508             subchap=1
3509           endif
3510        enddo
3511        enddo
3512        enddo
3513        if (subchap.eq.1) then
3514           xj=xj_temp-xi
3515           yj=yj_temp-yi
3516           zj=zj_temp-zi
3517        else
3518           xj=xj_safe-xi
3519           yj=yj_safe-yi
3520           zj=zj_safe-zi
3521        endif
3522           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3523 C sss is scaling function for smoothing the cutoff gradient otherwise
3524 C the gradient would not be continuouse
3525           sss=sscale(1.0d0/(dsqrt(rrij)))
3526           if (sss.le.0.0d0) cycle
3527           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3528           fac=rrij**expon2
3529           e1=fac*fac*aad(itypj,iteli)
3530           e2=fac*bad(itypj,iteli)
3531           if (iabs(j-i) .le. 2) then
3532             e1=scal14*e1
3533             e2=scal14*e2
3534             evdw2_14=evdw2_14+(e1+e2)*sss
3535           endif
3536           evdwij=e1+e2
3537 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3538 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3539 c     &       bad(itypj,iteli)
3540           evdw2=evdw2+evdwij*sss
3541           if (calc_grad) then
3542 C
3543 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3544 C
3545           fac=-(evdwij+e1)*rrij*sss
3546           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3547           ggg(1)=xj*fac
3548           ggg(2)=yj*fac
3549           ggg(3)=zj*fac
3550           if (j.lt.i) then
3551 cd          write (iout,*) 'j<i'
3552 C Uncomment following three lines for SC-p interactions
3553 c           do k=1,3
3554 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3555 c           enddo
3556           else
3557 cd          write (iout,*) 'j>i'
3558             do k=1,3
3559               ggg(k)=-ggg(k)
3560 C Uncomment following line for SC-p interactions
3561 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3562             enddo
3563           endif
3564           do k=1,3
3565             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3566           enddo
3567           kstart=min0(i+1,j)
3568           kend=max0(i-1,j-1)
3569 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3570 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3571           do k=kstart,kend
3572             do l=1,3
3573               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3574             enddo
3575           enddo
3576           endif
3577         enddo
3578         enddo ! iint
3579  1225   continue
3580       enddo ! i
3581       do i=1,nct
3582         do j=1,3
3583           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3584           gradx_scp(j,i)=expon*gradx_scp(j,i)
3585         enddo
3586       enddo
3587 C******************************************************************************
3588 C
3589 C                              N O T E !!!
3590 C
3591 C To save time the factor EXPON has been extracted from ALL components
3592 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3593 C use!
3594 C
3595 C******************************************************************************
3596       return
3597       end
3598 C--------------------------------------------------------------------------
3599       subroutine edis(ehpb)
3600 C
3601 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3602 C
3603       implicit real*8 (a-h,o-z)
3604       include 'DIMENSIONS'
3605       include 'DIMENSIONS.ZSCOPT'
3606       include 'COMMON.SBRIDGE'
3607       include 'COMMON.CHAIN'
3608       include 'COMMON.DERIV'
3609       include 'COMMON.VAR'
3610       include 'COMMON.INTERACT'
3611       include 'COMMON.CONTROL'
3612       include 'COMMON.IOUNITS'
3613       dimension ggg(3)
3614       ehpb=0.0D0
3615 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3616 cd    print *,'link_start=',link_start,' link_end=',link_end
3617 C      write(iout,*) link_end, "link_end"
3618       if (link_end.eq.0) return
3619       do i=link_start,link_end
3620 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3621 C CA-CA distance used in regularization of structure.
3622         ii=ihpb(i)
3623         jj=jhpb(i)
3624 C iii and jjj point to the residues for which the distance is assigned.
3625         if (ii.gt.nres) then
3626           iii=ii-nres
3627           jjj=jj-nres
3628         else
3629           iii=ii
3630           jjj=jj
3631         endif
3632 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3633 C    distance and angle dependent SS bond potential.
3634 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3635 C     & iabs(itype(jjj)).eq.1) then
3636 C       write(iout,*) constr_dist,"const"
3637        if (.not.dyn_ss .and. i.le.nss) then
3638          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3639      & iabs(itype(jjj)).eq.1) then
3640           call ssbond_ene(iii,jjj,eij)
3641           ehpb=ehpb+2*eij
3642            endif !ii.gt.neres
3643         else if (ii.gt.nres .and. jj.gt.nres) then
3644 c Restraints from contact prediction
3645           dd=dist(ii,jj)
3646           if (constr_dist.eq.11) then
3647 C            ehpb=ehpb+fordepth(i)**4.0d0
3648 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3649             ehpb=ehpb+fordepth(i)**4.0d0
3650      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3651             fac=fordepth(i)**4.0d0
3652      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3653 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3654 C     &    ehpb,fordepth(i),dd
3655 C            write(iout,*) ehpb,"atu?"
3656 C            ehpb,"tu?"
3657 C            fac=fordepth(i)**4.0d0
3658 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3659            else
3660           if (dhpb1(i).gt.0.0d0) then
3661             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3662             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3663 c            write (iout,*) "beta nmr",
3664 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3665           else
3666             dd=dist(ii,jj)
3667             rdis=dd-dhpb(i)
3668 C Get the force constant corresponding to this distance.
3669             waga=forcon(i)
3670 C Calculate the contribution to energy.
3671             ehpb=ehpb+waga*rdis*rdis
3672 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3673 C
3674 C Evaluate gradient.
3675 C
3676             fac=waga*rdis/dd
3677           endif !end dhpb1(i).gt.0
3678           endif !end const_dist=11
3679           do j=1,3
3680             ggg(j)=fac*(c(j,jj)-c(j,ii))
3681           enddo
3682           do j=1,3
3683             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3684             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3685           enddo
3686           do k=1,3
3687             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3688             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3689           enddo
3690         else !ii.gt.nres
3691 C          write(iout,*) "before"
3692           dd=dist(ii,jj)
3693 C          write(iout,*) "after",dd
3694           if (constr_dist.eq.11) then
3695             ehpb=ehpb+fordepth(i)**4.0d0
3696      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3697             fac=fordepth(i)**4.0d0
3698      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3699 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3700 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3701 C            print *,ehpb,"tu?"
3702 C            write(iout,*) ehpb,"btu?",
3703 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3704 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3705 C     &    ehpb,fordepth(i),dd
3706            else
3707           if (dhpb1(i).gt.0.0d0) then
3708             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3709             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3710 c            write (iout,*) "alph nmr",
3711 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3712           else
3713             rdis=dd-dhpb(i)
3714 C Get the force constant corresponding to this distance.
3715             waga=forcon(i)
3716 C Calculate the contribution to energy.
3717             ehpb=ehpb+waga*rdis*rdis
3718 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3719 C
3720 C Evaluate gradient.
3721 C
3722             fac=waga*rdis/dd
3723           endif
3724           endif
3725
3726         do j=1,3
3727           ggg(j)=fac*(c(j,jj)-c(j,ii))
3728         enddo
3729 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3730 C If this is a SC-SC distance, we need to calculate the contributions to the
3731 C Cartesian gradient in the SC vectors (ghpbx).
3732         if (iii.lt.ii) then
3733           do j=1,3
3734             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3735             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3736           enddo
3737         endif
3738         do j=iii,jjj-1
3739           do k=1,3
3740             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3741           enddo
3742         enddo
3743         endif
3744       enddo
3745       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3746       return
3747       end
3748 C--------------------------------------------------------------------------
3749       subroutine ssbond_ene(i,j,eij)
3750 C
3751 C Calculate the distance and angle dependent SS-bond potential energy
3752 C using a free-energy function derived based on RHF/6-31G** ab initio
3753 C calculations of diethyl disulfide.
3754 C
3755 C A. Liwo and U. Kozlowska, 11/24/03
3756 C
3757       implicit real*8 (a-h,o-z)
3758       include 'DIMENSIONS'
3759       include 'DIMENSIONS.ZSCOPT'
3760       include 'COMMON.SBRIDGE'
3761       include 'COMMON.CHAIN'
3762       include 'COMMON.DERIV'
3763       include 'COMMON.LOCAL'
3764       include 'COMMON.INTERACT'
3765       include 'COMMON.VAR'
3766       include 'COMMON.IOUNITS'
3767       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3768       itypi=iabs(itype(i))
3769       xi=c(1,nres+i)
3770       yi=c(2,nres+i)
3771       zi=c(3,nres+i)
3772       dxi=dc_norm(1,nres+i)
3773       dyi=dc_norm(2,nres+i)
3774       dzi=dc_norm(3,nres+i)
3775       dsci_inv=dsc_inv(itypi)
3776       itypj=iabs(itype(j))
3777       dscj_inv=dsc_inv(itypj)
3778       xj=c(1,nres+j)-xi
3779       yj=c(2,nres+j)-yi
3780       zj=c(3,nres+j)-zi
3781       dxj=dc_norm(1,nres+j)
3782       dyj=dc_norm(2,nres+j)
3783       dzj=dc_norm(3,nres+j)
3784       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3785       rij=dsqrt(rrij)
3786       erij(1)=xj*rij
3787       erij(2)=yj*rij
3788       erij(3)=zj*rij
3789       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3790       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3791       om12=dxi*dxj+dyi*dyj+dzi*dzj
3792       do k=1,3
3793         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3794         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3795       enddo
3796       rij=1.0d0/rij
3797       deltad=rij-d0cm
3798       deltat1=1.0d0-om1
3799       deltat2=1.0d0+om2
3800       deltat12=om2-om1+2.0d0
3801       cosphi=om12-om1*om2
3802       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3803      &  +akct*deltad*deltat12
3804      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3805 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3806 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3807 c     &  " deltat12",deltat12," eij",eij
3808       ed=2*akcm*deltad+akct*deltat12
3809       pom1=akct*deltad
3810       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3811       eom1=-2*akth*deltat1-pom1-om2*pom2
3812       eom2= 2*akth*deltat2+pom1-om1*pom2
3813       eom12=pom2
3814       do k=1,3
3815         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3816       enddo
3817       do k=1,3
3818         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3819      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3820         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3821      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3822       enddo
3823 C
3824 C Calculate the components of the gradient in DC and X
3825 C
3826       do k=i,j-1
3827         do l=1,3
3828           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3829         enddo
3830       enddo
3831       return
3832       end
3833 C--------------------------------------------------------------------------
3834       subroutine ebond(estr)
3835 c
3836 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3837 c
3838       implicit real*8 (a-h,o-z)
3839       include 'DIMENSIONS'
3840       include 'DIMENSIONS.ZSCOPT'
3841       include 'COMMON.LOCAL'
3842       include 'COMMON.GEO'
3843       include 'COMMON.INTERACT'
3844       include 'COMMON.DERIV'
3845       include 'COMMON.VAR'
3846       include 'COMMON.CHAIN'
3847       include 'COMMON.IOUNITS'
3848       include 'COMMON.NAMES'
3849       include 'COMMON.FFIELD'
3850       include 'COMMON.CONTROL'
3851       logical energy_dec /.false./
3852       double precision u(3),ud(3)
3853       estr=0.0d0
3854       estr1=0.0d0
3855 c      write (iout,*) "distchainmax",distchainmax
3856       do i=nnt+1,nct
3857         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3858 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3859 C          do j=1,3
3860 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3861 C     &      *dc(j,i-1)/vbld(i)
3862 C          enddo
3863 C          if (energy_dec) write(iout,*)
3864 C     &       "estr1",i,vbld(i),distchainmax,
3865 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3866 C        else
3867          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3868         diff = vbld(i)-vbldpDUM
3869 C         write(iout,*) i,diff
3870          else
3871           diff = vbld(i)-vbldp0
3872 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3873          endif
3874           estr=estr+diff*diff
3875           do j=1,3
3876             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3877           enddo
3878 C        endif
3879 C        write (iout,'(a7,i5,4f7.3)')
3880 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3881       enddo
3882       estr=0.5d0*AKP*estr+estr1
3883 c
3884 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3885 c
3886       do i=nnt,nct
3887         iti=iabs(itype(i))
3888         if (iti.ne.10 .and. iti.ne.ntyp1) then
3889           nbi=nbondterm(iti)
3890           if (nbi.eq.1) then
3891             diff=vbld(i+nres)-vbldsc0(1,iti)
3892 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3893 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3894             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3895             do j=1,3
3896               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3897             enddo
3898           else
3899             do j=1,nbi
3900               diff=vbld(i+nres)-vbldsc0(j,iti)
3901               ud(j)=aksc(j,iti)*diff
3902               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3903             enddo
3904             uprod=u(1)
3905             do j=2,nbi
3906               uprod=uprod*u(j)
3907             enddo
3908             usum=0.0d0
3909             usumsqder=0.0d0
3910             do j=1,nbi
3911               uprod1=1.0d0
3912               uprod2=1.0d0
3913               do k=1,nbi
3914                 if (k.ne.j) then
3915                   uprod1=uprod1*u(k)
3916                   uprod2=uprod2*u(k)*u(k)
3917                 endif
3918               enddo
3919               usum=usum+uprod1
3920               usumsqder=usumsqder+ud(j)*uprod2
3921             enddo
3922 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3923 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3924             estr=estr+uprod/usum
3925             do j=1,3
3926              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3927             enddo
3928           endif
3929         endif
3930       enddo
3931       return
3932       end
3933 #ifdef CRYST_THETA
3934 C--------------------------------------------------------------------------
3935       subroutine ebend(etheta,ethetacnstr)
3936 C
3937 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3938 C angles gamma and its derivatives in consecutive thetas and gammas.
3939 C
3940       implicit real*8 (a-h,o-z)
3941       include 'DIMENSIONS'
3942       include 'DIMENSIONS.ZSCOPT'
3943       include 'COMMON.LOCAL'
3944       include 'COMMON.GEO'
3945       include 'COMMON.INTERACT'
3946       include 'COMMON.DERIV'
3947       include 'COMMON.VAR'
3948       include 'COMMON.CHAIN'
3949       include 'COMMON.IOUNITS'
3950       include 'COMMON.NAMES'
3951       include 'COMMON.FFIELD'
3952       include 'COMMON.TORCNSTR'
3953       common /calcthet/ term1,term2,termm,diffak,ratak,
3954      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3955      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3956       double precision y(2),z(2)
3957       delta=0.02d0*pi
3958 c      time11=dexp(-2*time)
3959 c      time12=1.0d0
3960       etheta=0.0D0
3961 c      write (iout,*) "nres",nres
3962 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3963 c      write (iout,*) ithet_start,ithet_end
3964       do i=ithet_start,ithet_end
3965 C        if (itype(i-1).eq.ntyp1) cycle
3966         if (i.le.2) cycle
3967         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3968      &  .or.itype(i).eq.ntyp1) cycle
3969 C Zero the energy function and its derivative at 0 or pi.
3970         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3971         it=itype(i-1)
3972         ichir1=isign(1,itype(i-2))
3973         ichir2=isign(1,itype(i))
3974          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
3975          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
3976          if (itype(i-1).eq.10) then
3977           itype1=isign(10,itype(i-2))
3978           ichir11=isign(1,itype(i-2))
3979           ichir12=isign(1,itype(i-2))
3980           itype2=isign(10,itype(i))
3981           ichir21=isign(1,itype(i))
3982           ichir22=isign(1,itype(i))
3983          endif
3984          if (i.eq.3) then
3985           y(1)=0.0D0
3986           y(2)=0.0D0
3987           else
3988
3989         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3990 #ifdef OSF
3991           phii=phi(i)
3992 c          icrc=0
3993 c          call proc_proc(phii,icrc)
3994           if (icrc.eq.1) phii=150.0
3995 #else
3996           phii=phi(i)
3997 #endif
3998           y(1)=dcos(phii)
3999           y(2)=dsin(phii)
4000         else
4001           y(1)=0.0D0
4002           y(2)=0.0D0
4003         endif
4004         endif
4005         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4006 #ifdef OSF
4007           phii1=phi(i+1)
4008 c          icrc=0
4009 c          call proc_proc(phii1,icrc)
4010           if (icrc.eq.1) phii1=150.0
4011           phii1=pinorm(phii1)
4012           z(1)=cos(phii1)
4013 #else
4014           phii1=phi(i+1)
4015           z(1)=dcos(phii1)
4016 #endif
4017           z(2)=dsin(phii1)
4018         else
4019           z(1)=0.0D0
4020           z(2)=0.0D0
4021         endif
4022 C Calculate the "mean" value of theta from the part of the distribution
4023 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4024 C In following comments this theta will be referred to as t_c.
4025         thet_pred_mean=0.0d0
4026         do k=1,2
4027             athetk=athet(k,it,ichir1,ichir2)
4028             bthetk=bthet(k,it,ichir1,ichir2)
4029           if (it.eq.10) then
4030              athetk=athet(k,itype1,ichir11,ichir12)
4031              bthetk=bthet(k,itype2,ichir21,ichir22)
4032           endif
4033           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4034         enddo
4035 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4036         dthett=thet_pred_mean*ssd
4037         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4038 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4039 C Derivatives of the "mean" values in gamma1 and gamma2.
4040         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4041      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4042          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4043      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4044          if (it.eq.10) then
4045       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4046      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4047         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4048      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4049          endif
4050         if (theta(i).gt.pi-delta) then
4051           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4052      &         E_tc0)
4053           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4054           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4055           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4056      &        E_theta)
4057           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4058      &        E_tc)
4059         else if (theta(i).lt.delta) then
4060           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4061           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4062           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4063      &        E_theta)
4064           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4065           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4066      &        E_tc)
4067         else
4068           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4069      &        E_theta,E_tc)
4070         endif
4071         etheta=etheta+ethetai
4072 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4073 c     &      'ebend',i,ethetai,theta(i),itype(i)
4074 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4075 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4076         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4077         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4078         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4079 c 1215   continue
4080       enddo
4081       ethetacnstr=0.0d0
4082 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4083       do i=1,ntheta_constr
4084         itheta=itheta_constr(i)
4085         thetiii=theta(itheta)
4086         difi=pinorm(thetiii-theta_constr0(i))
4087         if (difi.gt.theta_drange(i)) then
4088           difi=difi-theta_drange(i)
4089           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4090           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4091      &    +for_thet_constr(i)*difi**3
4092         else if (difi.lt.-drange(i)) then
4093           difi=difi+drange(i)
4094           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4095           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4096      &    +for_thet_constr(i)*difi**3
4097         else
4098           difi=0.0
4099         endif
4100 C       if (energy_dec) then
4101 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4102 C     &    i,itheta,rad2deg*thetiii,
4103 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4104 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4105 C     &    gloc(itheta+nphi-2,icg)
4106 C        endif
4107       enddo
4108 C Ufff.... We've done all this!!!
4109       return
4110       end
4111 C---------------------------------------------------------------------------
4112       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4113      &     E_tc)
4114       implicit real*8 (a-h,o-z)
4115       include 'DIMENSIONS'
4116       include 'COMMON.LOCAL'
4117       include 'COMMON.IOUNITS'
4118       common /calcthet/ term1,term2,termm,diffak,ratak,
4119      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4120      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4121 C Calculate the contributions to both Gaussian lobes.
4122 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4123 C The "polynomial part" of the "standard deviation" of this part of
4124 C the distribution.
4125         sig=polthet(3,it)
4126         do j=2,0,-1
4127           sig=sig*thet_pred_mean+polthet(j,it)
4128         enddo
4129 C Derivative of the "interior part" of the "standard deviation of the"
4130 C gamma-dependent Gaussian lobe in t_c.
4131         sigtc=3*polthet(3,it)
4132         do j=2,1,-1
4133           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4134         enddo
4135         sigtc=sig*sigtc
4136 C Set the parameters of both Gaussian lobes of the distribution.
4137 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4138         fac=sig*sig+sigc0(it)
4139         sigcsq=fac+fac
4140         sigc=1.0D0/sigcsq
4141 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4142         sigsqtc=-4.0D0*sigcsq*sigtc
4143 c       print *,i,sig,sigtc,sigsqtc
4144 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4145         sigtc=-sigtc/(fac*fac)
4146 C Following variable is sigma(t_c)**(-2)
4147         sigcsq=sigcsq*sigcsq
4148         sig0i=sig0(it)
4149         sig0inv=1.0D0/sig0i**2
4150         delthec=thetai-thet_pred_mean
4151         delthe0=thetai-theta0i
4152         term1=-0.5D0*sigcsq*delthec*delthec
4153         term2=-0.5D0*sig0inv*delthe0*delthe0
4154 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4155 C NaNs in taking the logarithm. We extract the largest exponent which is added
4156 C to the energy (this being the log of the distribution) at the end of energy
4157 C term evaluation for this virtual-bond angle.
4158         if (term1.gt.term2) then
4159           termm=term1
4160           term2=dexp(term2-termm)
4161           term1=1.0d0
4162         else
4163           termm=term2
4164           term1=dexp(term1-termm)
4165           term2=1.0d0
4166         endif
4167 C The ratio between the gamma-independent and gamma-dependent lobes of
4168 C the distribution is a Gaussian function of thet_pred_mean too.
4169         diffak=gthet(2,it)-thet_pred_mean
4170         ratak=diffak/gthet(3,it)**2
4171         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4172 C Let's differentiate it in thet_pred_mean NOW.
4173         aktc=ak*ratak
4174 C Now put together the distribution terms to make complete distribution.
4175         termexp=term1+ak*term2
4176         termpre=sigc+ak*sig0i
4177 C Contribution of the bending energy from this theta is just the -log of
4178 C the sum of the contributions from the two lobes and the pre-exponential
4179 C factor. Simple enough, isn't it?
4180         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4181 C NOW the derivatives!!!
4182 C 6/6/97 Take into account the deformation.
4183         E_theta=(delthec*sigcsq*term1
4184      &       +ak*delthe0*sig0inv*term2)/termexp
4185         E_tc=((sigtc+aktc*sig0i)/termpre
4186      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4187      &       aktc*term2)/termexp)
4188       return
4189       end
4190 c-----------------------------------------------------------------------------
4191       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4192       implicit real*8 (a-h,o-z)
4193       include 'DIMENSIONS'
4194       include 'COMMON.LOCAL'
4195       include 'COMMON.IOUNITS'
4196       common /calcthet/ term1,term2,termm,diffak,ratak,
4197      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4198      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4199       delthec=thetai-thet_pred_mean
4200       delthe0=thetai-theta0i
4201 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4202       t3 = thetai-thet_pred_mean
4203       t6 = t3**2
4204       t9 = term1
4205       t12 = t3*sigcsq
4206       t14 = t12+t6*sigsqtc
4207       t16 = 1.0d0
4208       t21 = thetai-theta0i
4209       t23 = t21**2
4210       t26 = term2
4211       t27 = t21*t26
4212       t32 = termexp
4213       t40 = t32**2
4214       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4215      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4216      & *(-t12*t9-ak*sig0inv*t27)
4217       return
4218       end
4219 #else
4220 C--------------------------------------------------------------------------
4221       subroutine ebend(etheta,ethetacnstr)
4222 C
4223 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4224 C angles gamma and its derivatives in consecutive thetas and gammas.
4225 C ab initio-derived potentials from
4226 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4227 C
4228       implicit real*8 (a-h,o-z)
4229       include 'DIMENSIONS'
4230       include 'DIMENSIONS.ZSCOPT'
4231       include 'COMMON.LOCAL'
4232       include 'COMMON.GEO'
4233       include 'COMMON.INTERACT'
4234       include 'COMMON.DERIV'
4235       include 'COMMON.VAR'
4236       include 'COMMON.CHAIN'
4237       include 'COMMON.IOUNITS'
4238       include 'COMMON.NAMES'
4239       include 'COMMON.FFIELD'
4240       include 'COMMON.CONTROL'
4241       include 'COMMON.TORCNSTR'
4242       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4243      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4244      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4245      & sinph1ph2(maxdouble,maxdouble)
4246       logical lprn /.false./, lprn1 /.false./
4247       etheta=0.0D0
4248 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4249       do i=ithet_start,ithet_end
4250 C         if (i.eq.2) cycle
4251 C        if (itype(i-1).eq.ntyp1) cycle
4252         if (i.le.2) cycle
4253         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4254      &  .or.itype(i).eq.ntyp1) cycle
4255         if (iabs(itype(i+1)).eq.20) iblock=2
4256         if (iabs(itype(i+1)).ne.20) iblock=1
4257         dethetai=0.0d0
4258         dephii=0.0d0
4259         dephii1=0.0d0
4260         theti2=0.5d0*theta(i)
4261         ityp2=ithetyp((itype(i-1)))
4262         do k=1,nntheterm
4263           coskt(k)=dcos(k*theti2)
4264           sinkt(k)=dsin(k*theti2)
4265         enddo
4266         if (i.eq.3) then
4267           phii=0.0d0
4268           ityp1=nthetyp+1
4269           do k=1,nsingle
4270             cosph1(k)=0.0d0
4271             sinph1(k)=0.0d0
4272           enddo
4273         else
4274         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4275 #ifdef OSF
4276           phii=phi(i)
4277           if (phii.ne.phii) phii=150.0
4278 #else
4279           phii=phi(i)
4280 #endif
4281           ityp1=ithetyp((itype(i-2)))
4282           do k=1,nsingle
4283             cosph1(k)=dcos(k*phii)
4284             sinph1(k)=dsin(k*phii)
4285           enddo
4286         else
4287           phii=0.0d0
4288 c          ityp1=nthetyp+1
4289           do k=1,nsingle
4290             ityp1=ithetyp((itype(i-2)))
4291             cosph1(k)=0.0d0
4292             sinph1(k)=0.0d0
4293           enddo
4294         endif
4295         endif
4296         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4297 #ifdef OSF
4298           phii1=phi(i+1)
4299           if (phii1.ne.phii1) phii1=150.0
4300           phii1=pinorm(phii1)
4301 #else
4302           phii1=phi(i+1)
4303 #endif
4304           ityp3=ithetyp((itype(i)))
4305           do k=1,nsingle
4306             cosph2(k)=dcos(k*phii1)
4307             sinph2(k)=dsin(k*phii1)
4308           enddo
4309         else
4310           phii1=0.0d0
4311 c          ityp3=nthetyp+1
4312           ityp3=ithetyp((itype(i)))
4313           do k=1,nsingle
4314             cosph2(k)=0.0d0
4315             sinph2(k)=0.0d0
4316           enddo
4317         endif
4318 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4319 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4320 c        call flush(iout)
4321         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4322         do k=1,ndouble
4323           do l=1,k-1
4324             ccl=cosph1(l)*cosph2(k-l)
4325             ssl=sinph1(l)*sinph2(k-l)
4326             scl=sinph1(l)*cosph2(k-l)
4327             csl=cosph1(l)*sinph2(k-l)
4328             cosph1ph2(l,k)=ccl-ssl
4329             cosph1ph2(k,l)=ccl+ssl
4330             sinph1ph2(l,k)=scl+csl
4331             sinph1ph2(k,l)=scl-csl
4332           enddo
4333         enddo
4334         if (lprn) then
4335         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4336      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4337         write (iout,*) "coskt and sinkt"
4338         do k=1,nntheterm
4339           write (iout,*) k,coskt(k),sinkt(k)
4340         enddo
4341         endif
4342         do k=1,ntheterm
4343           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4344           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4345      &      *coskt(k)
4346           if (lprn)
4347      &    write (iout,*) "k",k,"
4348      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4349      &     " ethetai",ethetai
4350         enddo
4351         if (lprn) then
4352         write (iout,*) "cosph and sinph"
4353         do k=1,nsingle
4354           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4355         enddo
4356         write (iout,*) "cosph1ph2 and sinph2ph2"
4357         do k=2,ndouble
4358           do l=1,k-1
4359             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4360      &         sinph1ph2(l,k),sinph1ph2(k,l)
4361           enddo
4362         enddo
4363         write(iout,*) "ethetai",ethetai
4364         endif
4365         do m=1,ntheterm2
4366           do k=1,nsingle
4367             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4368      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4369      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4370      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4371             ethetai=ethetai+sinkt(m)*aux
4372             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4373             dephii=dephii+k*sinkt(m)*(
4374      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4375      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4376             dephii1=dephii1+k*sinkt(m)*(
4377      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4378      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4379             if (lprn)
4380      &      write (iout,*) "m",m," k",k," bbthet",
4381      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4382      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4383      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4384      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4385           enddo
4386         enddo
4387         if (lprn)
4388      &  write(iout,*) "ethetai",ethetai
4389         do m=1,ntheterm3
4390           do k=2,ndouble
4391             do l=1,k-1
4392               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4393      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4394      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4395      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4396               ethetai=ethetai+sinkt(m)*aux
4397               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4398               dephii=dephii+l*sinkt(m)*(
4399      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4400      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4401      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4402      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4403               dephii1=dephii1+(k-l)*sinkt(m)*(
4404      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4405      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4406      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4407      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4408               if (lprn) then
4409               write (iout,*) "m",m," k",k," l",l," ffthet",
4410      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4411      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4412      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4413      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4414      &            " ethetai",ethetai
4415               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4416      &            cosph1ph2(k,l)*sinkt(m),
4417      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4418               endif
4419             enddo
4420           enddo
4421         enddo
4422 10      continue
4423         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4424      &   i,theta(i)*rad2deg,phii*rad2deg,
4425      &   phii1*rad2deg,ethetai
4426         etheta=etheta+ethetai
4427         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4428         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4429 c        gloc(nphi+i-2,icg)=wang*dethetai
4430         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4431       enddo
4432 C now constrains
4433       ethetacnstr=0.0d0
4434 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4435       do i=1,ntheta_constr
4436         itheta=itheta_constr(i)
4437         thetiii=theta(itheta)
4438         difi=pinorm(thetiii-theta_constr0(i))
4439         if (difi.gt.theta_drange(i)) then
4440           difi=difi-theta_drange(i)
4441           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4442           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4443      &    +for_thet_constr(i)*difi**3
4444         else if (difi.lt.-drange(i)) then
4445           difi=difi+drange(i)
4446           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4447           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4448      &    +for_thet_constr(i)*difi**3
4449         else
4450           difi=0.0
4451         endif
4452 C       if (energy_dec) then
4453 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4454 C     &    i,itheta,rad2deg*thetiii,
4455 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4456 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4457 C     &    gloc(itheta+nphi-2,icg)
4458 C        endif
4459       enddo
4460       return
4461       end
4462 #endif
4463 #ifdef CRYST_SC
4464 c-----------------------------------------------------------------------------
4465       subroutine esc(escloc)
4466 C Calculate the local energy of a side chain and its derivatives in the
4467 C corresponding virtual-bond valence angles THETA and the spherical angles
4468 C ALPHA and OMEGA.
4469       implicit real*8 (a-h,o-z)
4470       include 'DIMENSIONS'
4471       include 'DIMENSIONS.ZSCOPT'
4472       include 'COMMON.GEO'
4473       include 'COMMON.LOCAL'
4474       include 'COMMON.VAR'
4475       include 'COMMON.INTERACT'
4476       include 'COMMON.DERIV'
4477       include 'COMMON.CHAIN'
4478       include 'COMMON.IOUNITS'
4479       include 'COMMON.NAMES'
4480       include 'COMMON.FFIELD'
4481       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4482      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4483       common /sccalc/ time11,time12,time112,theti,it,nlobit
4484       delta=0.02d0*pi
4485       escloc=0.0D0
4486 C      write (iout,*) 'ESC'
4487       do i=loc_start,loc_end
4488         it=itype(i)
4489         if (it.eq.ntyp1) cycle
4490         if (it.eq.10) goto 1
4491         nlobit=nlob(iabs(it))
4492 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4493 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4494         theti=theta(i+1)-pipol
4495         x(1)=dtan(theti)
4496         x(2)=alph(i)
4497         x(3)=omeg(i)
4498 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4499
4500         if (x(2).gt.pi-delta) then
4501           xtemp(1)=x(1)
4502           xtemp(2)=pi-delta
4503           xtemp(3)=x(3)
4504           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4505           xtemp(2)=pi
4506           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4507           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4508      &        escloci,dersc(2))
4509           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4510      &        ddersc0(1),dersc(1))
4511           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4512      &        ddersc0(3),dersc(3))
4513           xtemp(2)=pi-delta
4514           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4515           xtemp(2)=pi
4516           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4517           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4518      &            dersc0(2),esclocbi,dersc02)
4519           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4520      &            dersc12,dersc01)
4521           call splinthet(x(2),0.5d0*delta,ss,ssd)
4522           dersc0(1)=dersc01
4523           dersc0(2)=dersc02
4524           dersc0(3)=0.0d0
4525           do k=1,3
4526             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4527           enddo
4528           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4529           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4530      &             esclocbi,ss,ssd
4531           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4532 c         escloci=esclocbi
4533 c         write (iout,*) escloci
4534         else if (x(2).lt.delta) then
4535           xtemp(1)=x(1)
4536           xtemp(2)=delta
4537           xtemp(3)=x(3)
4538           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4539           xtemp(2)=0.0d0
4540           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4541           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4542      &        escloci,dersc(2))
4543           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4544      &        ddersc0(1),dersc(1))
4545           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4546      &        ddersc0(3),dersc(3))
4547           xtemp(2)=delta
4548           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4549           xtemp(2)=0.0d0
4550           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4551           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4552      &            dersc0(2),esclocbi,dersc02)
4553           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4554      &            dersc12,dersc01)
4555           dersc0(1)=dersc01
4556           dersc0(2)=dersc02
4557           dersc0(3)=0.0d0
4558           call splinthet(x(2),0.5d0*delta,ss,ssd)
4559           do k=1,3
4560             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4561           enddo
4562           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4563 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4564 c     &             esclocbi,ss,ssd
4565           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4566 C         write (iout,*) 'i=',i, escloci
4567         else
4568           call enesc(x,escloci,dersc,ddummy,.false.)
4569         endif
4570
4571         escloc=escloc+escloci
4572 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4573             write (iout,'(a6,i5,0pf7.3)')
4574      &     'escloc',i,escloci
4575
4576         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4577      &   wscloc*dersc(1)
4578         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4579         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4580     1   continue
4581       enddo
4582       return
4583       end
4584 C---------------------------------------------------------------------------
4585       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4586       implicit real*8 (a-h,o-z)
4587       include 'DIMENSIONS'
4588       include 'COMMON.GEO'
4589       include 'COMMON.LOCAL'
4590       include 'COMMON.IOUNITS'
4591       common /sccalc/ time11,time12,time112,theti,it,nlobit
4592       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4593       double precision contr(maxlob,-1:1)
4594       logical mixed
4595 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4596         escloc_i=0.0D0
4597         do j=1,3
4598           dersc(j)=0.0D0
4599           if (mixed) ddersc(j)=0.0d0
4600         enddo
4601         x3=x(3)
4602
4603 C Because of periodicity of the dependence of the SC energy in omega we have
4604 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4605 C To avoid underflows, first compute & store the exponents.
4606
4607         do iii=-1,1
4608
4609           x(3)=x3+iii*dwapi
4610
4611           do j=1,nlobit
4612             do k=1,3
4613               z(k)=x(k)-censc(k,j,it)
4614             enddo
4615             do k=1,3
4616               Axk=0.0D0
4617               do l=1,3
4618                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4619               enddo
4620               Ax(k,j,iii)=Axk
4621             enddo
4622             expfac=0.0D0
4623             do k=1,3
4624               expfac=expfac+Ax(k,j,iii)*z(k)
4625             enddo
4626             contr(j,iii)=expfac
4627           enddo ! j
4628
4629         enddo ! iii
4630
4631         x(3)=x3
4632 C As in the case of ebend, we want to avoid underflows in exponentiation and
4633 C subsequent NaNs and INFs in energy calculation.
4634 C Find the largest exponent
4635         emin=contr(1,-1)
4636         do iii=-1,1
4637           do j=1,nlobit
4638             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4639           enddo
4640         enddo
4641         emin=0.5D0*emin
4642 cd      print *,'it=',it,' emin=',emin
4643
4644 C Compute the contribution to SC energy and derivatives
4645         do iii=-1,1
4646
4647           do j=1,nlobit
4648             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4649 cd          print *,'j=',j,' expfac=',expfac
4650             escloc_i=escloc_i+expfac
4651             do k=1,3
4652               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4653             enddo
4654             if (mixed) then
4655               do k=1,3,2
4656                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4657      &            +gaussc(k,2,j,it))*expfac
4658               enddo
4659             endif
4660           enddo
4661
4662         enddo ! iii
4663
4664         dersc(1)=dersc(1)/cos(theti)**2
4665         ddersc(1)=ddersc(1)/cos(theti)**2
4666         ddersc(3)=ddersc(3)
4667
4668         escloci=-(dlog(escloc_i)-emin)
4669         do j=1,3
4670           dersc(j)=dersc(j)/escloc_i
4671         enddo
4672         if (mixed) then
4673           do j=1,3,2
4674             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4675           enddo
4676         endif
4677       return
4678       end
4679 C------------------------------------------------------------------------------
4680       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4681       implicit real*8 (a-h,o-z)
4682       include 'DIMENSIONS'
4683       include 'COMMON.GEO'
4684       include 'COMMON.LOCAL'
4685       include 'COMMON.IOUNITS'
4686       common /sccalc/ time11,time12,time112,theti,it,nlobit
4687       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4688       double precision contr(maxlob)
4689       logical mixed
4690
4691       escloc_i=0.0D0
4692
4693       do j=1,3
4694         dersc(j)=0.0D0
4695       enddo
4696
4697       do j=1,nlobit
4698         do k=1,2
4699           z(k)=x(k)-censc(k,j,it)
4700         enddo
4701         z(3)=dwapi
4702         do k=1,3
4703           Axk=0.0D0
4704           do l=1,3
4705             Axk=Axk+gaussc(l,k,j,it)*z(l)
4706           enddo
4707           Ax(k,j)=Axk
4708         enddo
4709         expfac=0.0D0
4710         do k=1,3
4711           expfac=expfac+Ax(k,j)*z(k)
4712         enddo
4713         contr(j)=expfac
4714       enddo ! j
4715
4716 C As in the case of ebend, we want to avoid underflows in exponentiation and
4717 C subsequent NaNs and INFs in energy calculation.
4718 C Find the largest exponent
4719       emin=contr(1)
4720       do j=1,nlobit
4721         if (emin.gt.contr(j)) emin=contr(j)
4722       enddo
4723       emin=0.5D0*emin
4724
4725 C Compute the contribution to SC energy and derivatives
4726
4727       dersc12=0.0d0
4728       do j=1,nlobit
4729         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4730         escloc_i=escloc_i+expfac
4731         do k=1,2
4732           dersc(k)=dersc(k)+Ax(k,j)*expfac
4733         enddo
4734         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4735      &            +gaussc(1,2,j,it))*expfac
4736         dersc(3)=0.0d0
4737       enddo
4738
4739       dersc(1)=dersc(1)/cos(theti)**2
4740       dersc12=dersc12/cos(theti)**2
4741       escloci=-(dlog(escloc_i)-emin)
4742       do j=1,2
4743         dersc(j)=dersc(j)/escloc_i
4744       enddo
4745       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4746       return
4747       end
4748 #else
4749 c----------------------------------------------------------------------------------
4750       subroutine esc(escloc)
4751 C Calculate the local energy of a side chain and its derivatives in the
4752 C corresponding virtual-bond valence angles THETA and the spherical angles
4753 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4754 C added by Urszula Kozlowska. 07/11/2007
4755 C
4756       implicit real*8 (a-h,o-z)
4757       include 'DIMENSIONS'
4758       include 'DIMENSIONS.ZSCOPT'
4759       include 'COMMON.GEO'
4760       include 'COMMON.LOCAL'
4761       include 'COMMON.VAR'
4762       include 'COMMON.SCROT'
4763       include 'COMMON.INTERACT'
4764       include 'COMMON.DERIV'
4765       include 'COMMON.CHAIN'
4766       include 'COMMON.IOUNITS'
4767       include 'COMMON.NAMES'
4768       include 'COMMON.FFIELD'
4769       include 'COMMON.CONTROL'
4770       include 'COMMON.VECTORS'
4771       double precision x_prime(3),y_prime(3),z_prime(3)
4772      &    , sumene,dsc_i,dp2_i,x(65),
4773      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4774      &    de_dxx,de_dyy,de_dzz,de_dt
4775       double precision s1_t,s1_6_t,s2_t,s2_6_t
4776       double precision
4777      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4778      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4779      & dt_dCi(3),dt_dCi1(3)
4780       common /sccalc/ time11,time12,time112,theti,it,nlobit
4781       delta=0.02d0*pi
4782       escloc=0.0D0
4783       do i=loc_start,loc_end
4784         if (itype(i).eq.ntyp1) cycle
4785         costtab(i+1) =dcos(theta(i+1))
4786         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4787         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4788         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4789         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4790         cosfac=dsqrt(cosfac2)
4791         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4792         sinfac=dsqrt(sinfac2)
4793         it=iabs(itype(i))
4794         if (it.eq.10) goto 1
4795 c
4796 C  Compute the axes of tghe local cartesian coordinates system; store in
4797 c   x_prime, y_prime and z_prime
4798 c
4799         do j=1,3
4800           x_prime(j) = 0.00
4801           y_prime(j) = 0.00
4802           z_prime(j) = 0.00
4803         enddo
4804 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4805 C     &   dc_norm(3,i+nres)
4806         do j = 1,3
4807           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4808           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4809         enddo
4810         do j = 1,3
4811           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4812         enddo
4813 c       write (2,*) "i",i
4814 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4815 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4816 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4817 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4818 c      & " xy",scalar(x_prime(1),y_prime(1)),
4819 c      & " xz",scalar(x_prime(1),z_prime(1)),
4820 c      & " yy",scalar(y_prime(1),y_prime(1)),
4821 c      & " yz",scalar(y_prime(1),z_prime(1)),
4822 c      & " zz",scalar(z_prime(1),z_prime(1))
4823 c
4824 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4825 C to local coordinate system. Store in xx, yy, zz.
4826 c
4827         xx=0.0d0
4828         yy=0.0d0
4829         zz=0.0d0
4830         do j = 1,3
4831           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4832           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4833           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4834         enddo
4835
4836         xxtab(i)=xx
4837         yytab(i)=yy
4838         zztab(i)=zz
4839 C
4840 C Compute the energy of the ith side cbain
4841 C
4842 c        write (2,*) "xx",xx," yy",yy," zz",zz
4843         it=iabs(itype(i))
4844         do j = 1,65
4845           x(j) = sc_parmin(j,it)
4846         enddo
4847 #ifdef CHECK_COORD
4848 Cc diagnostics - remove later
4849         xx1 = dcos(alph(2))
4850         yy1 = dsin(alph(2))*dcos(omeg(2))
4851         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4852         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4853      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4854      &    xx1,yy1,zz1
4855 C,"  --- ", xx_w,yy_w,zz_w
4856 c end diagnostics
4857 #endif
4858         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4859      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4860      &   + x(10)*yy*zz
4861         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4862      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4863      & + x(20)*yy*zz
4864         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4865      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4866      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4867      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4868      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4869      &  +x(40)*xx*yy*zz
4870         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4871      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4872      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4873      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4874      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4875      &  +x(60)*xx*yy*zz
4876         dsc_i   = 0.743d0+x(61)
4877         dp2_i   = 1.9d0+x(62)
4878         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4879      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4880         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4881      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4882         s1=(1+x(63))/(0.1d0 + dscp1)
4883         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4884         s2=(1+x(65))/(0.1d0 + dscp2)
4885         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4886         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4887      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4888 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4889 c     &   sumene4,
4890 c     &   dscp1,dscp2,sumene
4891 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4892         escloc = escloc + sumene
4893 c        write (2,*) "escloc",escloc
4894 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
4895 c     &  zz,xx,yy
4896         if (.not. calc_grad) goto 1
4897 #ifdef DEBUG
4898 C
4899 C This section to check the numerical derivatives of the energy of ith side
4900 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4901 C #define DEBUG in the code to turn it on.
4902 C
4903         write (2,*) "sumene               =",sumene
4904         aincr=1.0d-7
4905         xxsave=xx
4906         xx=xx+aincr
4907         write (2,*) xx,yy,zz
4908         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4909         de_dxx_num=(sumenep-sumene)/aincr
4910         xx=xxsave
4911         write (2,*) "xx+ sumene from enesc=",sumenep
4912         yysave=yy
4913         yy=yy+aincr
4914         write (2,*) xx,yy,zz
4915         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4916         de_dyy_num=(sumenep-sumene)/aincr
4917         yy=yysave
4918         write (2,*) "yy+ sumene from enesc=",sumenep
4919         zzsave=zz
4920         zz=zz+aincr
4921         write (2,*) xx,yy,zz
4922         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4923         de_dzz_num=(sumenep-sumene)/aincr
4924         zz=zzsave
4925         write (2,*) "zz+ sumene from enesc=",sumenep
4926         costsave=cost2tab(i+1)
4927         sintsave=sint2tab(i+1)
4928         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4929         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4930         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4931         de_dt_num=(sumenep-sumene)/aincr
4932         write (2,*) " t+ sumene from enesc=",sumenep
4933         cost2tab(i+1)=costsave
4934         sint2tab(i+1)=sintsave
4935 C End of diagnostics section.
4936 #endif
4937 C
4938 C Compute the gradient of esc
4939 C
4940         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4941         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4942         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4943         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4944         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4945         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4946         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4947         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4948         pom1=(sumene3*sint2tab(i+1)+sumene1)
4949      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4950         pom2=(sumene4*cost2tab(i+1)+sumene2)
4951      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4952         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4953         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4954      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4955      &  +x(40)*yy*zz
4956         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4957         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4958      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4959      &  +x(60)*yy*zz
4960         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4961      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4962      &        +(pom1+pom2)*pom_dx
4963 #ifdef DEBUG
4964         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4965 #endif
4966 C
4967         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4968         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4969      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4970      &  +x(40)*xx*zz
4971         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4972         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4973      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4974      &  +x(59)*zz**2 +x(60)*xx*zz
4975         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4976      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4977      &        +(pom1-pom2)*pom_dy
4978 #ifdef DEBUG
4979         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4980 #endif
4981 C
4982         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4983      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4984      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4985      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4986      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4987      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4988      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4989      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4990 #ifdef DEBUG
4991         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4992 #endif
4993 C
4994         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4995      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4996      &  +pom1*pom_dt1+pom2*pom_dt2
4997 #ifdef DEBUG
4998         write(2,*), "de_dt = ", de_dt,de_dt_num
4999 #endif
5000 c
5001 C
5002        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5003        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5004        cosfac2xx=cosfac2*xx
5005        sinfac2yy=sinfac2*yy
5006        do k = 1,3
5007          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5008      &      vbld_inv(i+1)
5009          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5010      &      vbld_inv(i)
5011          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5012          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5013 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5014 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5015 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5016 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5017          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5018          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5019          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5020          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5021          dZZ_Ci1(k)=0.0d0
5022          dZZ_Ci(k)=0.0d0
5023          do j=1,3
5024            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5025      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5026            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5027      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5028          enddo
5029
5030          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5031          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5032          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5033 c
5034          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5035          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5036        enddo
5037
5038        do k=1,3
5039          dXX_Ctab(k,i)=dXX_Ci(k)
5040          dXX_C1tab(k,i)=dXX_Ci1(k)
5041          dYY_Ctab(k,i)=dYY_Ci(k)
5042          dYY_C1tab(k,i)=dYY_Ci1(k)
5043          dZZ_Ctab(k,i)=dZZ_Ci(k)
5044          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5045          dXX_XYZtab(k,i)=dXX_XYZ(k)
5046          dYY_XYZtab(k,i)=dYY_XYZ(k)
5047          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5048        enddo
5049
5050        do k = 1,3
5051 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5052 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5053 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5054 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5055 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5056 c     &    dt_dci(k)
5057 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5058 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5059          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5060      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5061          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5062      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5063          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5064      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5065        enddo
5066 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5067 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5068
5069 C to check gradient call subroutine check_grad
5070
5071     1 continue
5072       enddo
5073       return
5074       end
5075 #endif
5076 c------------------------------------------------------------------------------
5077       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5078 C
5079 C This procedure calculates two-body contact function g(rij) and its derivative:
5080 C
5081 C           eps0ij                                     !       x < -1
5082 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5083 C            0                                         !       x > 1
5084 C
5085 C where x=(rij-r0ij)/delta
5086 C
5087 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5088 C
5089       implicit none
5090       double precision rij,r0ij,eps0ij,fcont,fprimcont
5091       double precision x,x2,x4,delta
5092 c     delta=0.02D0*r0ij
5093 c      delta=0.2D0*r0ij
5094       x=(rij-r0ij)/delta
5095       if (x.lt.-1.0D0) then
5096         fcont=eps0ij
5097         fprimcont=0.0D0
5098       else if (x.le.1.0D0) then
5099         x2=x*x
5100         x4=x2*x2
5101         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5102         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5103       else
5104         fcont=0.0D0
5105         fprimcont=0.0D0
5106       endif
5107       return
5108       end
5109 c------------------------------------------------------------------------------
5110       subroutine splinthet(theti,delta,ss,ssder)
5111       implicit real*8 (a-h,o-z)
5112       include 'DIMENSIONS'
5113       include 'DIMENSIONS.ZSCOPT'
5114       include 'COMMON.VAR'
5115       include 'COMMON.GEO'
5116       thetup=pi-delta
5117       thetlow=delta
5118       if (theti.gt.pipol) then
5119         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5120       else
5121         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5122         ssder=-ssder
5123       endif
5124       return
5125       end
5126 c------------------------------------------------------------------------------
5127       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5128       implicit none
5129       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5130       double precision ksi,ksi2,ksi3,a1,a2,a3
5131       a1=fprim0*delta/(f1-f0)
5132       a2=3.0d0-2.0d0*a1
5133       a3=a1-2.0d0
5134       ksi=(x-x0)/delta
5135       ksi2=ksi*ksi
5136       ksi3=ksi2*ksi
5137       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5138       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5139       return
5140       end
5141 c------------------------------------------------------------------------------
5142       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5143       implicit none
5144       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5145       double precision ksi,ksi2,ksi3,a1,a2,a3
5146       ksi=(x-x0)/delta
5147       ksi2=ksi*ksi
5148       ksi3=ksi2*ksi
5149       a1=fprim0x*delta
5150       a2=3*(f1x-f0x)-2*fprim0x*delta
5151       a3=fprim0x*delta-2*(f1x-f0x)
5152       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5153       return
5154       end
5155 C-----------------------------------------------------------------------------
5156 #ifdef CRYST_TOR
5157 C-----------------------------------------------------------------------------
5158       subroutine etor(etors,edihcnstr,fact)
5159       implicit real*8 (a-h,o-z)
5160       include 'DIMENSIONS'
5161       include 'DIMENSIONS.ZSCOPT'
5162       include 'COMMON.VAR'
5163       include 'COMMON.GEO'
5164       include 'COMMON.LOCAL'
5165       include 'COMMON.TORSION'
5166       include 'COMMON.INTERACT'
5167       include 'COMMON.DERIV'
5168       include 'COMMON.CHAIN'
5169       include 'COMMON.NAMES'
5170       include 'COMMON.IOUNITS'
5171       include 'COMMON.FFIELD'
5172       include 'COMMON.TORCNSTR'
5173       logical lprn
5174 C Set lprn=.true. for debugging
5175       lprn=.false.
5176 c      lprn=.true.
5177       etors=0.0D0
5178       do i=iphi_start,iphi_end
5179         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5180      &      .or. itype(i).eq.ntyp1) cycle
5181         itori=itortyp(itype(i-2))
5182         itori1=itortyp(itype(i-1))
5183         phii=phi(i)
5184         gloci=0.0D0
5185 C Proline-Proline pair is a special case...
5186         if (itori.eq.3 .and. itori1.eq.3) then
5187           if (phii.gt.-dwapi3) then
5188             cosphi=dcos(3*phii)
5189             fac=1.0D0/(1.0D0-cosphi)
5190             etorsi=v1(1,3,3)*fac
5191             etorsi=etorsi+etorsi
5192             etors=etors+etorsi-v1(1,3,3)
5193             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5194           endif
5195           do j=1,3
5196             v1ij=v1(j+1,itori,itori1)
5197             v2ij=v2(j+1,itori,itori1)
5198             cosphi=dcos(j*phii)
5199             sinphi=dsin(j*phii)
5200             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5201             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5202           enddo
5203         else
5204           do j=1,nterm_old
5205             v1ij=v1(j,itori,itori1)
5206             v2ij=v2(j,itori,itori1)
5207             cosphi=dcos(j*phii)
5208             sinphi=dsin(j*phii)
5209             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5210             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5211           enddo
5212         endif
5213         if (lprn)
5214      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5215      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5216      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5217         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5218 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5219       enddo
5220 ! 6/20/98 - dihedral angle constraints
5221       edihcnstr=0.0d0
5222       do i=1,ndih_constr
5223         itori=idih_constr(i)
5224         phii=phi(itori)
5225         difi=phii-phi0(i)
5226         if (difi.gt.drange(i)) then
5227           difi=difi-drange(i)
5228           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5229           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5230         else if (difi.lt.-drange(i)) then
5231           difi=difi+drange(i)
5232           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5233           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5234         endif
5235 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5236 C     &    i,itori,rad2deg*phii,
5237 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5238       enddo
5239 !      write (iout,*) 'edihcnstr',edihcnstr
5240       return
5241       end
5242 c------------------------------------------------------------------------------
5243 #else
5244       subroutine etor(etors,edihcnstr,fact)
5245       implicit real*8 (a-h,o-z)
5246       include 'DIMENSIONS'
5247       include 'DIMENSIONS.ZSCOPT'
5248       include 'COMMON.VAR'
5249       include 'COMMON.GEO'
5250       include 'COMMON.LOCAL'
5251       include 'COMMON.TORSION'
5252       include 'COMMON.INTERACT'
5253       include 'COMMON.DERIV'
5254       include 'COMMON.CHAIN'
5255       include 'COMMON.NAMES'
5256       include 'COMMON.IOUNITS'
5257       include 'COMMON.FFIELD'
5258       include 'COMMON.TORCNSTR'
5259       logical lprn
5260 C Set lprn=.true. for debugging
5261       lprn=.false.
5262 c      lprn=.true.
5263       etors=0.0D0
5264       do i=iphi_start,iphi_end
5265         if (i.le.2) cycle
5266         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5267      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5268 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5269 C     &       .or. itype(i).eq.ntyp1) cycle
5270         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5271          if (iabs(itype(i)).eq.20) then
5272          iblock=2
5273          else
5274          iblock=1
5275          endif
5276         itori=itortyp(itype(i-2))
5277         itori1=itortyp(itype(i-1))
5278         phii=phi(i)
5279         gloci=0.0D0
5280 C Regular cosine and sine terms
5281         do j=1,nterm(itori,itori1,iblock)
5282           v1ij=v1(j,itori,itori1,iblock)
5283           v2ij=v2(j,itori,itori1,iblock)
5284           cosphi=dcos(j*phii)
5285           sinphi=dsin(j*phii)
5286           etors=etors+v1ij*cosphi+v2ij*sinphi
5287           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5288         enddo
5289 C Lorentz terms
5290 C                         v1
5291 C  E = SUM ----------------------------------- - v1
5292 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5293 C
5294         cosphi=dcos(0.5d0*phii)
5295         sinphi=dsin(0.5d0*phii)
5296         do j=1,nlor(itori,itori1,iblock)
5297           vl1ij=vlor1(j,itori,itori1)
5298           vl2ij=vlor2(j,itori,itori1)
5299           vl3ij=vlor3(j,itori,itori1)
5300           pom=vl2ij*cosphi+vl3ij*sinphi
5301           pom1=1.0d0/(pom*pom+1.0d0)
5302           etors=etors+vl1ij*pom1
5303 c          if (energy_dec) etors_ii=etors_ii+
5304 c     &                vl1ij*pom1
5305           pom=-pom*pom1*pom1
5306           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5307         enddo
5308 C Subtract the constant term
5309         etors=etors-v0(itori,itori1,iblock)
5310         if (lprn)
5311      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5312      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5313      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5314         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5315 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5316  1215   continue
5317       enddo
5318 ! 6/20/98 - dihedral angle constraints
5319       edihcnstr=0.0d0
5320       do i=1,ndih_constr
5321         itori=idih_constr(i)
5322         phii=phi(itori)
5323         difi=pinorm(phii-phi0(i))
5324         edihi=0.0d0
5325         if (difi.gt.drange(i)) then
5326           difi=difi-drange(i)
5327           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5328           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5329           edihi=0.25d0*ftors(i)*difi**4
5330         else if (difi.lt.-drange(i)) then
5331           difi=difi+drange(i)
5332           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5333           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5334           edihi=0.25d0*ftors(i)*difi**4
5335         else
5336           difi=0.0d0
5337         endif
5338         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5339      &    i,itori,rad2deg*phii,
5340      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5341 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5342 c     &    drange(i),edihi
5343 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5344 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5345       enddo
5346 !      write (iout,*) 'edihcnstr',edihcnstr
5347       return
5348       end
5349 c----------------------------------------------------------------------------
5350       subroutine etor_d(etors_d,fact2)
5351 C 6/23/01 Compute double torsional energy
5352       implicit real*8 (a-h,o-z)
5353       include 'DIMENSIONS'
5354       include 'DIMENSIONS.ZSCOPT'
5355       include 'COMMON.VAR'
5356       include 'COMMON.GEO'
5357       include 'COMMON.LOCAL'
5358       include 'COMMON.TORSION'
5359       include 'COMMON.INTERACT'
5360       include 'COMMON.DERIV'
5361       include 'COMMON.CHAIN'
5362       include 'COMMON.NAMES'
5363       include 'COMMON.IOUNITS'
5364       include 'COMMON.FFIELD'
5365       include 'COMMON.TORCNSTR'
5366       logical lprn
5367 C Set lprn=.true. for debugging
5368       lprn=.false.
5369 c     lprn=.true.
5370       etors_d=0.0D0
5371       do i=iphi_start,iphi_end-1
5372         if (i.le.3) cycle
5373 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5374 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5375          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5376      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5377      &  (itype(i+1).eq.ntyp1)) cycle
5378         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5379      &     goto 1215
5380         itori=itortyp(itype(i-2))
5381         itori1=itortyp(itype(i-1))
5382         itori2=itortyp(itype(i))
5383         phii=phi(i)
5384         phii1=phi(i+1)
5385         gloci1=0.0D0
5386         gloci2=0.0D0
5387         iblock=1
5388         if (iabs(itype(i+1)).eq.20) iblock=2
5389 C Regular cosine and sine terms
5390         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5391           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5392           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5393           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5394           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5395           cosphi1=dcos(j*phii)
5396           sinphi1=dsin(j*phii)
5397           cosphi2=dcos(j*phii1)
5398           sinphi2=dsin(j*phii1)
5399           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5400      &     v2cij*cosphi2+v2sij*sinphi2
5401           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5402           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5403         enddo
5404         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5405           do l=1,k-1
5406             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5407             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5408             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5409             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5410             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5411             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5412             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5413             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5414             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5415      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5416             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5417      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5418             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5419      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5420           enddo
5421         enddo
5422         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5423         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5424  1215   continue
5425       enddo
5426       return
5427       end
5428 #endif
5429 c------------------------------------------------------------------------------
5430       subroutine eback_sc_corr(esccor)
5431 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5432 c        conformational states; temporarily implemented as differences
5433 c        between UNRES torsional potentials (dependent on three types of
5434 c        residues) and the torsional potentials dependent on all 20 types
5435 c        of residues computed from AM1 energy surfaces of terminally-blocked
5436 c        amino-acid residues.
5437       implicit real*8 (a-h,o-z)
5438       include 'DIMENSIONS'
5439       include 'DIMENSIONS.ZSCOPT'
5440       include 'COMMON.VAR'
5441       include 'COMMON.GEO'
5442       include 'COMMON.LOCAL'
5443       include 'COMMON.TORSION'
5444       include 'COMMON.SCCOR'
5445       include 'COMMON.INTERACT'
5446       include 'COMMON.DERIV'
5447       include 'COMMON.CHAIN'
5448       include 'COMMON.NAMES'
5449       include 'COMMON.IOUNITS'
5450       include 'COMMON.FFIELD'
5451       include 'COMMON.CONTROL'
5452       logical lprn
5453 C Set lprn=.true. for debugging
5454       lprn=.false.
5455 c      lprn=.true.
5456 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5457       esccor=0.0D0
5458       do i=itau_start,itau_end
5459         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5460         esccor_ii=0.0D0
5461         isccori=isccortyp(itype(i-2))
5462         isccori1=isccortyp(itype(i-1))
5463         phii=phi(i)
5464         do intertyp=1,3 !intertyp
5465 cc Added 09 May 2012 (Adasko)
5466 cc  Intertyp means interaction type of backbone mainchain correlation:
5467 c   1 = SC...Ca...Ca...Ca
5468 c   2 = Ca...Ca...Ca...SC
5469 c   3 = SC...Ca...Ca...SCi
5470         gloci=0.0D0
5471         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5472      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5473      &      (itype(i-1).eq.ntyp1)))
5474      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5475      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5476      &     .or.(itype(i).eq.ntyp1)))
5477      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5478      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5479      &      (itype(i-3).eq.ntyp1)))) cycle
5480         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5481         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5482      & cycle
5483        do j=1,nterm_sccor(isccori,isccori1)
5484           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5485           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5486           cosphi=dcos(j*tauangle(intertyp,i))
5487           sinphi=dsin(j*tauangle(intertyp,i))
5488            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5489            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5490          enddo
5491 C      write (iout,*)"EBACK_SC_COR",esccor,i
5492 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5493 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5494 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5495         if (lprn)
5496      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5497      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5498      &  (v1sccor(j,1,itori,itori1),j=1,6)
5499      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5500 c        gsccor_loc(i-3)=gloci
5501        enddo !intertyp
5502       enddo
5503       return
5504       end
5505 c------------------------------------------------------------------------------
5506       subroutine multibody(ecorr)
5507 C This subroutine calculates multi-body contributions to energy following
5508 C the idea of Skolnick et al. If side chains I and J make a contact and
5509 C at the same time side chains I+1 and J+1 make a contact, an extra
5510 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5511       implicit real*8 (a-h,o-z)
5512       include 'DIMENSIONS'
5513       include 'COMMON.IOUNITS'
5514       include 'COMMON.DERIV'
5515       include 'COMMON.INTERACT'
5516       include 'COMMON.CONTACTS'
5517       double precision gx(3),gx1(3)
5518       logical lprn
5519
5520 C Set lprn=.true. for debugging
5521       lprn=.false.
5522
5523       if (lprn) then
5524         write (iout,'(a)') 'Contact function values:'
5525         do i=nnt,nct-2
5526           write (iout,'(i2,20(1x,i2,f10.5))')
5527      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5528         enddo
5529       endif
5530       ecorr=0.0D0
5531       do i=nnt,nct
5532         do j=1,3
5533           gradcorr(j,i)=0.0D0
5534           gradxorr(j,i)=0.0D0
5535         enddo
5536       enddo
5537       do i=nnt,nct-2
5538
5539         DO ISHIFT = 3,4
5540
5541         i1=i+ishift
5542         num_conti=num_cont(i)
5543         num_conti1=num_cont(i1)
5544         do jj=1,num_conti
5545           j=jcont(jj,i)
5546           do kk=1,num_conti1
5547             j1=jcont(kk,i1)
5548             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5549 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5550 cd   &                   ' ishift=',ishift
5551 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5552 C The system gains extra energy.
5553               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5554             endif   ! j1==j+-ishift
5555           enddo     ! kk
5556         enddo       ! jj
5557
5558         ENDDO ! ISHIFT
5559
5560       enddo         ! i
5561       return
5562       end
5563 c------------------------------------------------------------------------------
5564       double precision function esccorr(i,j,k,l,jj,kk)
5565       implicit real*8 (a-h,o-z)
5566       include 'DIMENSIONS'
5567       include 'COMMON.IOUNITS'
5568       include 'COMMON.DERIV'
5569       include 'COMMON.INTERACT'
5570       include 'COMMON.CONTACTS'
5571       double precision gx(3),gx1(3)
5572       logical lprn
5573       lprn=.false.
5574       eij=facont(jj,i)
5575       ekl=facont(kk,k)
5576 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5577 C Calculate the multi-body contribution to energy.
5578 C Calculate multi-body contributions to the gradient.
5579 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5580 cd   & k,l,(gacont(m,kk,k),m=1,3)
5581       do m=1,3
5582         gx(m) =ekl*gacont(m,jj,i)
5583         gx1(m)=eij*gacont(m,kk,k)
5584         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5585         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5586         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5587         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5588       enddo
5589       do m=i,j-1
5590         do ll=1,3
5591           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5592         enddo
5593       enddo
5594       do m=k,l-1
5595         do ll=1,3
5596           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5597         enddo
5598       enddo
5599       esccorr=-eij*ekl
5600       return
5601       end
5602 c------------------------------------------------------------------------------
5603 #ifdef MPL
5604       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5605       implicit real*8 (a-h,o-z)
5606       include 'DIMENSIONS'
5607       integer dimen1,dimen2,atom,indx
5608       double precision buffer(dimen1,dimen2)
5609       double precision zapas
5610       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5611      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5612      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5613       num_kont=num_cont_hb(atom)
5614       do i=1,num_kont
5615         do k=1,7
5616           do j=1,3
5617             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5618           enddo ! j
5619         enddo ! k
5620         buffer(i,indx+22)=facont_hb(i,atom)
5621         buffer(i,indx+23)=ees0p(i,atom)
5622         buffer(i,indx+24)=ees0m(i,atom)
5623         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5624       enddo ! i
5625       buffer(1,indx+26)=dfloat(num_kont)
5626       return
5627       end
5628 c------------------------------------------------------------------------------
5629       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5630       implicit real*8 (a-h,o-z)
5631       include 'DIMENSIONS'
5632       integer dimen1,dimen2,atom,indx
5633       double precision buffer(dimen1,dimen2)
5634       double precision zapas
5635       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5636      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5637      &         ees0m(ntyp,maxres),
5638      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5639       num_kont=buffer(1,indx+26)
5640       num_kont_old=num_cont_hb(atom)
5641       num_cont_hb(atom)=num_kont+num_kont_old
5642       do i=1,num_kont
5643         ii=i+num_kont_old
5644         do k=1,7
5645           do j=1,3
5646             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5647           enddo ! j
5648         enddo ! k
5649         facont_hb(ii,atom)=buffer(i,indx+22)
5650         ees0p(ii,atom)=buffer(i,indx+23)
5651         ees0m(ii,atom)=buffer(i,indx+24)
5652         jcont_hb(ii,atom)=buffer(i,indx+25)
5653       enddo ! i
5654       return
5655       end
5656 c------------------------------------------------------------------------------
5657 #endif
5658       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5659 C This subroutine calculates multi-body contributions to hydrogen-bonding
5660       implicit real*8 (a-h,o-z)
5661       include 'DIMENSIONS'
5662       include 'DIMENSIONS.ZSCOPT'
5663       include 'COMMON.IOUNITS'
5664 #ifdef MPL
5665       include 'COMMON.INFO'
5666 #endif
5667       include 'COMMON.FFIELD'
5668       include 'COMMON.DERIV'
5669       include 'COMMON.INTERACT'
5670       include 'COMMON.CONTACTS'
5671 #ifdef MPL
5672       parameter (max_cont=maxconts)
5673       parameter (max_dim=2*(8*3+2))
5674       parameter (msglen1=max_cont*max_dim*4)
5675       parameter (msglen2=2*msglen1)
5676       integer source,CorrelType,CorrelID,Error
5677       double precision buffer(max_cont,max_dim)
5678 #endif
5679       double precision gx(3),gx1(3)
5680       logical lprn,ldone
5681
5682 C Set lprn=.true. for debugging
5683       lprn=.false.
5684 #ifdef MPL
5685       n_corr=0
5686       n_corr1=0
5687       if (fgProcs.le.1) goto 30
5688       if (lprn) then
5689         write (iout,'(a)') 'Contact function values:'
5690         do i=nnt,nct-2
5691           write (iout,'(2i3,50(1x,i2,f5.2))')
5692      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5693      &    j=1,num_cont_hb(i))
5694         enddo
5695       endif
5696 C Caution! Following code assumes that electrostatic interactions concerning
5697 C a given atom are split among at most two processors!
5698       CorrelType=477
5699       CorrelID=MyID+1
5700       ldone=.false.
5701       do i=1,max_cont
5702         do j=1,max_dim
5703           buffer(i,j)=0.0D0
5704         enddo
5705       enddo
5706       mm=mod(MyRank,2)
5707 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5708       if (mm) 20,20,10
5709    10 continue
5710 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5711       if (MyRank.gt.0) then
5712 C Send correlation contributions to the preceding processor
5713         msglen=msglen1
5714         nn=num_cont_hb(iatel_s)
5715         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5716 cd      write (iout,*) 'The BUFFER array:'
5717 cd      do i=1,nn
5718 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5719 cd      enddo
5720         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5721           msglen=msglen2
5722             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5723 C Clear the contacts of the atom passed to the neighboring processor
5724         nn=num_cont_hb(iatel_s+1)
5725 cd      do i=1,nn
5726 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5727 cd      enddo
5728             num_cont_hb(iatel_s)=0
5729         endif
5730 cd      write (iout,*) 'Processor ',MyID,MyRank,
5731 cd   & ' is sending correlation contribution to processor',MyID-1,
5732 cd   & ' msglen=',msglen
5733 cd      write (*,*) 'Processor ',MyID,MyRank,
5734 cd   & ' is sending correlation contribution to processor',MyID-1,
5735 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5736         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5737 cd      write (iout,*) 'Processor ',MyID,
5738 cd   & ' has sent correlation contribution to processor',MyID-1,
5739 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5740 cd      write (*,*) 'Processor ',MyID,
5741 cd   & ' has sent correlation contribution to processor',MyID-1,
5742 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5743         msglen=msglen1
5744       endif ! (MyRank.gt.0)
5745       if (ldone) goto 30
5746       ldone=.true.
5747    20 continue
5748 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5749       if (MyRank.lt.fgProcs-1) then
5750 C Receive correlation contributions from the next processor
5751         msglen=msglen1
5752         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5753 cd      write (iout,*) 'Processor',MyID,
5754 cd   & ' is receiving correlation contribution from processor',MyID+1,
5755 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5756 cd      write (*,*) 'Processor',MyID,
5757 cd   & ' is receiving correlation contribution from processor',MyID+1,
5758 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5759         nbytes=-1
5760         do while (nbytes.le.0)
5761           call mp_probe(MyID+1,CorrelType,nbytes)
5762         enddo
5763 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5764         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5765 cd      write (iout,*) 'Processor',MyID,
5766 cd   & ' has received correlation contribution from processor',MyID+1,
5767 cd   & ' msglen=',msglen,' nbytes=',nbytes
5768 cd      write (iout,*) 'The received BUFFER array:'
5769 cd      do i=1,max_cont
5770 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5771 cd      enddo
5772         if (msglen.eq.msglen1) then
5773           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5774         else if (msglen.eq.msglen2)  then
5775           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5776           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5777         else
5778           write (iout,*)
5779      & 'ERROR!!!! message length changed while processing correlations.'
5780           write (*,*)
5781      & 'ERROR!!!! message length changed while processing correlations.'
5782           call mp_stopall(Error)
5783         endif ! msglen.eq.msglen1
5784       endif ! MyRank.lt.fgProcs-1
5785       if (ldone) goto 30
5786       ldone=.true.
5787       goto 10
5788    30 continue
5789 #endif
5790       if (lprn) then
5791         write (iout,'(a)') 'Contact function values:'
5792         do i=nnt,nct-2
5793           write (iout,'(2i3,50(1x,i2,f5.2))')
5794      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5795      &    j=1,num_cont_hb(i))
5796         enddo
5797       endif
5798       ecorr=0.0D0
5799 C Remove the loop below after debugging !!!
5800       do i=nnt,nct
5801         do j=1,3
5802           gradcorr(j,i)=0.0D0
5803           gradxorr(j,i)=0.0D0
5804         enddo
5805       enddo
5806 C Calculate the local-electrostatic correlation terms
5807       do i=iatel_s,iatel_e+1
5808         i1=i+1
5809         num_conti=num_cont_hb(i)
5810         num_conti1=num_cont_hb(i+1)
5811         do jj=1,num_conti
5812           j=jcont_hb(jj,i)
5813           do kk=1,num_conti1
5814             j1=jcont_hb(kk,i1)
5815 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5816 c     &         ' jj=',jj,' kk=',kk
5817             if (j1.eq.j+1 .or. j1.eq.j-1) then
5818 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5819 C The system gains extra energy.
5820               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5821               n_corr=n_corr+1
5822             else if (j1.eq.j) then
5823 C Contacts I-J and I-(J+1) occur simultaneously.
5824 C The system loses extra energy.
5825 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5826             endif
5827           enddo ! kk
5828           do kk=1,num_conti
5829             j1=jcont_hb(kk,i)
5830 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5831 c    &         ' jj=',jj,' kk=',kk
5832             if (j1.eq.j+1) then
5833 C Contacts I-J and (I+1)-J occur simultaneously.
5834 C The system loses extra energy.
5835 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5836             endif ! j1==j+1
5837           enddo ! kk
5838         enddo ! jj
5839       enddo ! i
5840       return
5841       end
5842 c------------------------------------------------------------------------------
5843       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5844      &  n_corr1)
5845 C This subroutine calculates multi-body contributions to hydrogen-bonding
5846       implicit real*8 (a-h,o-z)
5847       include 'DIMENSIONS'
5848       include 'DIMENSIONS.ZSCOPT'
5849       include 'COMMON.IOUNITS'
5850 #ifdef MPL
5851       include 'COMMON.INFO'
5852 #endif
5853       include 'COMMON.FFIELD'
5854       include 'COMMON.DERIV'
5855       include 'COMMON.INTERACT'
5856       include 'COMMON.CONTACTS'
5857 #ifdef MPL
5858       parameter (max_cont=maxconts)
5859       parameter (max_dim=2*(8*3+2))
5860       parameter (msglen1=max_cont*max_dim*4)
5861       parameter (msglen2=2*msglen1)
5862       integer source,CorrelType,CorrelID,Error
5863       double precision buffer(max_cont,max_dim)
5864 #endif
5865       double precision gx(3),gx1(3)
5866       logical lprn,ldone
5867
5868 C Set lprn=.true. for debugging
5869       lprn=.false.
5870       eturn6=0.0d0
5871       ecorr6=0.0d0
5872 #ifdef MPL
5873       n_corr=0
5874       n_corr1=0
5875       if (fgProcs.le.1) goto 30
5876       if (lprn) then
5877         write (iout,'(a)') 'Contact function values:'
5878         do i=nnt,nct-2
5879           write (iout,'(2i3,50(1x,i2,f5.2))')
5880      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5881      &    j=1,num_cont_hb(i))
5882         enddo
5883       endif
5884 C Caution! Following code assumes that electrostatic interactions concerning
5885 C a given atom are split among at most two processors!
5886       CorrelType=477
5887       CorrelID=MyID+1
5888       ldone=.false.
5889       do i=1,max_cont
5890         do j=1,max_dim
5891           buffer(i,j)=0.0D0
5892         enddo
5893       enddo
5894       mm=mod(MyRank,2)
5895 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5896       if (mm) 20,20,10
5897    10 continue
5898 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5899       if (MyRank.gt.0) then
5900 C Send correlation contributions to the preceding processor
5901         msglen=msglen1
5902         nn=num_cont_hb(iatel_s)
5903         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5904 cd      write (iout,*) 'The BUFFER array:'
5905 cd      do i=1,nn
5906 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5907 cd      enddo
5908         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5909           msglen=msglen2
5910             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5911 C Clear the contacts of the atom passed to the neighboring processor
5912         nn=num_cont_hb(iatel_s+1)
5913 cd      do i=1,nn
5914 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5915 cd      enddo
5916             num_cont_hb(iatel_s)=0
5917         endif
5918 cd      write (iout,*) 'Processor ',MyID,MyRank,
5919 cd   & ' is sending correlation contribution to processor',MyID-1,
5920 cd   & ' msglen=',msglen
5921 cd      write (*,*) 'Processor ',MyID,MyRank,
5922 cd   & ' is sending correlation contribution to processor',MyID-1,
5923 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5924         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5925 cd      write (iout,*) 'Processor ',MyID,
5926 cd   & ' has sent correlation contribution to processor',MyID-1,
5927 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5928 cd      write (*,*) 'Processor ',MyID,
5929 cd   & ' has sent correlation contribution to processor',MyID-1,
5930 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5931         msglen=msglen1
5932       endif ! (MyRank.gt.0)
5933       if (ldone) goto 30
5934       ldone=.true.
5935    20 continue
5936 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5937       if (MyRank.lt.fgProcs-1) then
5938 C Receive correlation contributions from the next processor
5939         msglen=msglen1
5940         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5941 cd      write (iout,*) 'Processor',MyID,
5942 cd   & ' is receiving correlation contribution from processor',MyID+1,
5943 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5944 cd      write (*,*) 'Processor',MyID,
5945 cd   & ' is receiving correlation contribution from processor',MyID+1,
5946 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5947         nbytes=-1
5948         do while (nbytes.le.0)
5949           call mp_probe(MyID+1,CorrelType,nbytes)
5950         enddo
5951 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5952         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5953 cd      write (iout,*) 'Processor',MyID,
5954 cd   & ' has received correlation contribution from processor',MyID+1,
5955 cd   & ' msglen=',msglen,' nbytes=',nbytes
5956 cd      write (iout,*) 'The received BUFFER array:'
5957 cd      do i=1,max_cont
5958 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5959 cd      enddo
5960         if (msglen.eq.msglen1) then
5961           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5962         else if (msglen.eq.msglen2)  then
5963           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5964           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5965         else
5966           write (iout,*)
5967      & 'ERROR!!!! message length changed while processing correlations.'
5968           write (*,*)
5969      & 'ERROR!!!! message length changed while processing correlations.'
5970           call mp_stopall(Error)
5971         endif ! msglen.eq.msglen1
5972       endif ! MyRank.lt.fgProcs-1
5973       if (ldone) goto 30
5974       ldone=.true.
5975       goto 10
5976    30 continue
5977 #endif
5978       if (lprn) then
5979         write (iout,'(a)') 'Contact function values:'
5980         do i=nnt,nct-2
5981           write (iout,'(2i3,50(1x,i2,f5.2))')
5982      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5983      &    j=1,num_cont_hb(i))
5984         enddo
5985       endif
5986       ecorr=0.0D0
5987       ecorr5=0.0d0
5988       ecorr6=0.0d0
5989 C Remove the loop below after debugging !!!
5990       do i=nnt,nct
5991         do j=1,3
5992           gradcorr(j,i)=0.0D0
5993           gradxorr(j,i)=0.0D0
5994         enddo
5995       enddo
5996 C Calculate the dipole-dipole interaction energies
5997       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5998       do i=iatel_s,iatel_e+1
5999         num_conti=num_cont_hb(i)
6000         do jj=1,num_conti
6001           j=jcont_hb(jj,i)
6002           call dipole(i,j,jj)
6003         enddo
6004       enddo
6005       endif
6006 C Calculate the local-electrostatic correlation terms
6007       do i=iatel_s,iatel_e+1
6008         i1=i+1
6009         num_conti=num_cont_hb(i)
6010         num_conti1=num_cont_hb(i+1)
6011         do jj=1,num_conti
6012           j=jcont_hb(jj,i)
6013           do kk=1,num_conti1
6014             j1=jcont_hb(kk,i1)
6015 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6016 c     &         ' jj=',jj,' kk=',kk
6017             if (j1.eq.j+1 .or. j1.eq.j-1) then
6018 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6019 C The system gains extra energy.
6020               n_corr=n_corr+1
6021               sqd1=dsqrt(d_cont(jj,i))
6022               sqd2=dsqrt(d_cont(kk,i1))
6023               sred_geom = sqd1*sqd2
6024               IF (sred_geom.lt.cutoff_corr) THEN
6025                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6026      &            ekont,fprimcont)
6027 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6028 c     &         ' jj=',jj,' kk=',kk
6029                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6030                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6031                 do l=1,3
6032                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6033                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6034                 enddo
6035                 n_corr1=n_corr1+1
6036 cd               write (iout,*) 'sred_geom=',sred_geom,
6037 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6038                 call calc_eello(i,j,i+1,j1,jj,kk)
6039                 if (wcorr4.gt.0.0d0)
6040      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6041                 if (wcorr5.gt.0.0d0)
6042      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6043 c                print *,"wcorr5",ecorr5
6044 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6045 cd                write(2,*)'ijkl',i,j,i+1,j1
6046                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6047      &               .or. wturn6.eq.0.0d0))then
6048 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6049                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6050 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6051 cd     &            'ecorr6=',ecorr6
6052 cd                write (iout,'(4e15.5)') sred_geom,
6053 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6054 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6055 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6056                 else if (wturn6.gt.0.0d0
6057      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6058 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6059                   eturn6=eturn6+eello_turn6(i,jj,kk)
6060 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6061                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6062                    eturn6=0.0d0
6063                    ecorr6=0.0d0
6064                 endif
6065
6066               ENDIF
6067 1111          continue
6068             else if (j1.eq.j) then
6069 C Contacts I-J and I-(J+1) occur simultaneously.
6070 C The system loses extra energy.
6071 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6072             endif
6073           enddo ! kk
6074           do kk=1,num_conti
6075             j1=jcont_hb(kk,i)
6076 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6077 c    &         ' jj=',jj,' kk=',kk
6078             if (j1.eq.j+1) then
6079 C Contacts I-J and (I+1)-J occur simultaneously.
6080 C The system loses extra energy.
6081 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6082             endif ! j1==j+1
6083           enddo ! kk
6084         enddo ! jj
6085       enddo ! i
6086       write (iout,*) "eturn6",eturn6,ecorr6
6087       return
6088       end
6089 c------------------------------------------------------------------------------
6090       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6091       implicit real*8 (a-h,o-z)
6092       include 'DIMENSIONS'
6093       include 'COMMON.IOUNITS'
6094       include 'COMMON.DERIV'
6095       include 'COMMON.INTERACT'
6096       include 'COMMON.CONTACTS'
6097       include 'COMMON.CONTROL'
6098       include 'COMMON.SHIELD'
6099       double precision gx(3),gx1(3)
6100       logical lprn
6101       lprn=.false.
6102       eij=facont_hb(jj,i)
6103       ekl=facont_hb(kk,k)
6104       ees0pij=ees0p(jj,i)
6105       ees0pkl=ees0p(kk,k)
6106       ees0mij=ees0m(jj,i)
6107       ees0mkl=ees0m(kk,k)
6108       ekont=eij*ekl
6109       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6110 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6111 C Following 4 lines for diagnostics.
6112 cd    ees0pkl=0.0D0
6113 cd    ees0pij=1.0D0
6114 cd    ees0mkl=0.0D0
6115 cd    ees0mij=1.0D0
6116 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6117 c    &   ' and',k,l
6118 c     write (iout,*)'Contacts have occurred for peptide groups',
6119 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6120 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6121 C Calculate the multi-body contribution to energy.
6122 C      ecorr=ecorr+ekont*ees
6123       if (calc_grad) then
6124 C Calculate multi-body contributions to the gradient.
6125       do ll=1,3
6126         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6127         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6128      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6129      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6130         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6131      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6132      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6133         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6134         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6135      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6136      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6137         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6138      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6139      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6140       enddo
6141       do m=i+1,j-1
6142         do ll=1,3
6143           gradcorr(ll,m)=gradcorr(ll,m)+
6144      &     ees*ekl*gacont_hbr(ll,jj,i)-
6145      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6146      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6147         enddo
6148       enddo
6149       do m=k+1,l-1
6150         do ll=1,3
6151           gradcorr(ll,m)=gradcorr(ll,m)+
6152      &     ees*eij*gacont_hbr(ll,kk,k)-
6153      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6154      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6155         enddo
6156       enddo
6157       if (shield_mode.gt.0) then
6158        j=ees0plist(jj,i)
6159        l=ees0plist(kk,k)
6160 C        print *,i,j,fac_shield(i),fac_shield(j),
6161 C     &fac_shield(k),fac_shield(l)
6162         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6163      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6164           do ilist=1,ishield_list(i)
6165            iresshield=shield_list(ilist,i)
6166            do m=1,3
6167            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6168 C     &      *2.0
6169            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6170      &              rlocshield
6171      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6172             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6173      &+rlocshield
6174            enddo
6175           enddo
6176           do ilist=1,ishield_list(j)
6177            iresshield=shield_list(ilist,j)
6178            do m=1,3
6179            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6180 C     &     *2.0
6181            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6182      &              rlocshield
6183      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6184            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6185      &     +rlocshield
6186            enddo
6187           enddo
6188           do ilist=1,ishield_list(k)
6189            iresshield=shield_list(ilist,k)
6190            do m=1,3
6191            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6192 C     &     *2.0
6193            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6194      &              rlocshield
6195      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6196            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6197      &     +rlocshield
6198            enddo
6199           enddo
6200           do ilist=1,ishield_list(l)
6201            iresshield=shield_list(ilist,l)
6202            do m=1,3
6203            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6204 C     &     *2.0
6205            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6206      &              rlocshield
6207      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6208            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6209      &     +rlocshield
6210            enddo
6211           enddo
6212 C          print *,gshieldx(m,iresshield)
6213           do m=1,3
6214             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6215      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6216             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6217      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6218             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6219      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6220             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6221      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6222
6223             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6224      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6225             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6226      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6227             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6228      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6229             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6230      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6231
6232            enddo
6233       endif
6234       endif
6235       endif
6236       ehbcorr=ekont*ees
6237       return
6238       end
6239 C---------------------------------------------------------------------------
6240       subroutine dipole(i,j,jj)
6241       implicit real*8 (a-h,o-z)
6242       include 'DIMENSIONS'
6243       include 'DIMENSIONS.ZSCOPT'
6244       include 'COMMON.IOUNITS'
6245       include 'COMMON.CHAIN'
6246       include 'COMMON.FFIELD'
6247       include 'COMMON.DERIV'
6248       include 'COMMON.INTERACT'
6249       include 'COMMON.CONTACTS'
6250       include 'COMMON.TORSION'
6251       include 'COMMON.VAR'
6252       include 'COMMON.GEO'
6253       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6254      &  auxmat(2,2)
6255       iti1 = itortyp(itype(i+1))
6256       if (j.lt.nres-1) then
6257         if (itype(j).le.ntyp) then
6258           itj1 = itortyp(itype(j+1))
6259         else
6260           itj=ntortyp+1
6261         endif
6262       else
6263         itj1=ntortyp+1
6264       endif
6265       do iii=1,2
6266         dipi(iii,1)=Ub2(iii,i)
6267         dipderi(iii)=Ub2der(iii,i)
6268         dipi(iii,2)=b1(iii,iti1)
6269         dipj(iii,1)=Ub2(iii,j)
6270         dipderj(iii)=Ub2der(iii,j)
6271         dipj(iii,2)=b1(iii,itj1)
6272       enddo
6273       kkk=0
6274       do iii=1,2
6275         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6276         do jjj=1,2
6277           kkk=kkk+1
6278           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6279         enddo
6280       enddo
6281       if (.not.calc_grad) return
6282       do kkk=1,5
6283         do lll=1,3
6284           mmm=0
6285           do iii=1,2
6286             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6287      &        auxvec(1))
6288             do jjj=1,2
6289               mmm=mmm+1
6290               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6291             enddo
6292           enddo
6293         enddo
6294       enddo
6295       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6296       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6297       do iii=1,2
6298         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6299       enddo
6300       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6301       do iii=1,2
6302         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6303       enddo
6304       return
6305       end
6306 C---------------------------------------------------------------------------
6307       subroutine calc_eello(i,j,k,l,jj,kk)
6308 C
6309 C This subroutine computes matrices and vectors needed to calculate
6310 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6311 C
6312       implicit real*8 (a-h,o-z)
6313       include 'DIMENSIONS'
6314       include 'DIMENSIONS.ZSCOPT'
6315       include 'COMMON.IOUNITS'
6316       include 'COMMON.CHAIN'
6317       include 'COMMON.DERIV'
6318       include 'COMMON.INTERACT'
6319       include 'COMMON.CONTACTS'
6320       include 'COMMON.TORSION'
6321       include 'COMMON.VAR'
6322       include 'COMMON.GEO'
6323       include 'COMMON.FFIELD'
6324       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6325      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6326       logical lprn
6327       common /kutas/ lprn
6328 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6329 cd     & ' jj=',jj,' kk=',kk
6330 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6331       do iii=1,2
6332         do jjj=1,2
6333           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6334           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6335         enddo
6336       enddo
6337       call transpose2(aa1(1,1),aa1t(1,1))
6338       call transpose2(aa2(1,1),aa2t(1,1))
6339       do kkk=1,5
6340         do lll=1,3
6341           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6342      &      aa1tder(1,1,lll,kkk))
6343           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6344      &      aa2tder(1,1,lll,kkk))
6345         enddo
6346       enddo
6347       if (l.eq.j+1) then
6348 C parallel orientation of the two CA-CA-CA frames.
6349         if (i.gt.1 .and. itype(i).le.ntyp) then
6350           iti=itortyp(itype(i))
6351         else
6352           iti=ntortyp+1
6353         endif
6354         itk1=itortyp(itype(k+1))
6355         itj=itortyp(itype(j))
6356         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6357           itl1=itortyp(itype(l+1))
6358         else
6359           itl1=ntortyp+1
6360         endif
6361 C A1 kernel(j+1) A2T
6362 cd        do iii=1,2
6363 cd          write (iout,'(3f10.5,5x,3f10.5)')
6364 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6365 cd        enddo
6366         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6367      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6368      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6369 C Following matrices are needed only for 6-th order cumulants
6370         IF (wcorr6.gt.0.0d0) THEN
6371         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6372      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6373      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6374         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6375      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6376      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6377      &   ADtEAderx(1,1,1,1,1,1))
6378         lprn=.false.
6379         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6380      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6381      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6382      &   ADtEA1derx(1,1,1,1,1,1))
6383         ENDIF
6384 C End 6-th order cumulants
6385 cd        lprn=.false.
6386 cd        if (lprn) then
6387 cd        write (2,*) 'In calc_eello6'
6388 cd        do iii=1,2
6389 cd          write (2,*) 'iii=',iii
6390 cd          do kkk=1,5
6391 cd            write (2,*) 'kkk=',kkk
6392 cd            do jjj=1,2
6393 cd              write (2,'(3(2f10.5),5x)')
6394 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6395 cd            enddo
6396 cd          enddo
6397 cd        enddo
6398 cd        endif
6399         call transpose2(EUgder(1,1,k),auxmat(1,1))
6400         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6401         call transpose2(EUg(1,1,k),auxmat(1,1))
6402         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6403         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6404         do iii=1,2
6405           do kkk=1,5
6406             do lll=1,3
6407               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6408      &          EAEAderx(1,1,lll,kkk,iii,1))
6409             enddo
6410           enddo
6411         enddo
6412 C A1T kernel(i+1) A2
6413         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6414      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6415      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6416 C Following matrices are needed only for 6-th order cumulants
6417         IF (wcorr6.gt.0.0d0) THEN
6418         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6419      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6420      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6421         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6422      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6423      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6424      &   ADtEAderx(1,1,1,1,1,2))
6425         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6426      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6427      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6428      &   ADtEA1derx(1,1,1,1,1,2))
6429         ENDIF
6430 C End 6-th order cumulants
6431         call transpose2(EUgder(1,1,l),auxmat(1,1))
6432         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6433         call transpose2(EUg(1,1,l),auxmat(1,1))
6434         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6435         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6436         do iii=1,2
6437           do kkk=1,5
6438             do lll=1,3
6439               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6440      &          EAEAderx(1,1,lll,kkk,iii,2))
6441             enddo
6442           enddo
6443         enddo
6444 C AEAb1 and AEAb2
6445 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6446 C They are needed only when the fifth- or the sixth-order cumulants are
6447 C indluded.
6448         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6449         call transpose2(AEA(1,1,1),auxmat(1,1))
6450         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6451         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6452         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6453         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6454         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6455         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6456         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6457         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6458         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6459         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6460         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6461         call transpose2(AEA(1,1,2),auxmat(1,1))
6462         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6463         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6464         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6465         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6466         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6467         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6468         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6469         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6470         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6471         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6472         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6473 C Calculate the Cartesian derivatives of the vectors.
6474         do iii=1,2
6475           do kkk=1,5
6476             do lll=1,3
6477               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6478               call matvec2(auxmat(1,1),b1(1,iti),
6479      &          AEAb1derx(1,lll,kkk,iii,1,1))
6480               call matvec2(auxmat(1,1),Ub2(1,i),
6481      &          AEAb2derx(1,lll,kkk,iii,1,1))
6482               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6483      &          AEAb1derx(1,lll,kkk,iii,2,1))
6484               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6485      &          AEAb2derx(1,lll,kkk,iii,2,1))
6486               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6487               call matvec2(auxmat(1,1),b1(1,itj),
6488      &          AEAb1derx(1,lll,kkk,iii,1,2))
6489               call matvec2(auxmat(1,1),Ub2(1,j),
6490      &          AEAb2derx(1,lll,kkk,iii,1,2))
6491               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6492      &          AEAb1derx(1,lll,kkk,iii,2,2))
6493               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6494      &          AEAb2derx(1,lll,kkk,iii,2,2))
6495             enddo
6496           enddo
6497         enddo
6498         ENDIF
6499 C End vectors
6500       else
6501 C Antiparallel orientation of the two CA-CA-CA frames.
6502         if (i.gt.1 .and. itype(i).le.ntyp) then
6503           iti=itortyp(itype(i))
6504         else
6505           iti=ntortyp+1
6506         endif
6507         itk1=itortyp(itype(k+1))
6508         itl=itortyp(itype(l))
6509         itj=itortyp(itype(j))
6510         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6511           itj1=itortyp(itype(j+1))
6512         else
6513           itj1=ntortyp+1
6514         endif
6515 C A2 kernel(j-1)T A1T
6516         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6517      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6518      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6519 C Following matrices are needed only for 6-th order cumulants
6520         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6521      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6522         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6523      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6524      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6525         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6526      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6527      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6528      &   ADtEAderx(1,1,1,1,1,1))
6529         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6530      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6531      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6532      &   ADtEA1derx(1,1,1,1,1,1))
6533         ENDIF
6534 C End 6-th order cumulants
6535         call transpose2(EUgder(1,1,k),auxmat(1,1))
6536         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6537         call transpose2(EUg(1,1,k),auxmat(1,1))
6538         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6539         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6540         do iii=1,2
6541           do kkk=1,5
6542             do lll=1,3
6543               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6544      &          EAEAderx(1,1,lll,kkk,iii,1))
6545             enddo
6546           enddo
6547         enddo
6548 C A2T kernel(i+1)T A1
6549         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6550      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6551      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6552 C Following matrices are needed only for 6-th order cumulants
6553         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6554      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6555         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6556      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6557      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6558         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6559      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6560      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6561      &   ADtEAderx(1,1,1,1,1,2))
6562         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6563      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6564      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6565      &   ADtEA1derx(1,1,1,1,1,2))
6566         ENDIF
6567 C End 6-th order cumulants
6568         call transpose2(EUgder(1,1,j),auxmat(1,1))
6569         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6570         call transpose2(EUg(1,1,j),auxmat(1,1))
6571         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6572         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6573         do iii=1,2
6574           do kkk=1,5
6575             do lll=1,3
6576               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6577      &          EAEAderx(1,1,lll,kkk,iii,2))
6578             enddo
6579           enddo
6580         enddo
6581 C AEAb1 and AEAb2
6582 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6583 C They are needed only when the fifth- or the sixth-order cumulants are
6584 C indluded.
6585         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6586      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6587         call transpose2(AEA(1,1,1),auxmat(1,1))
6588         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6589         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6590         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6591         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6592         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6593         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6594         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6595         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6596         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6597         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6598         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6599         call transpose2(AEA(1,1,2),auxmat(1,1))
6600         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6601         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6602         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6603         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6604         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6605         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6606         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6607         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6608         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6609         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6610         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6611 C Calculate the Cartesian derivatives of the vectors.
6612         do iii=1,2
6613           do kkk=1,5
6614             do lll=1,3
6615               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6616               call matvec2(auxmat(1,1),b1(1,iti),
6617      &          AEAb1derx(1,lll,kkk,iii,1,1))
6618               call matvec2(auxmat(1,1),Ub2(1,i),
6619      &          AEAb2derx(1,lll,kkk,iii,1,1))
6620               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6621      &          AEAb1derx(1,lll,kkk,iii,2,1))
6622               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6623      &          AEAb2derx(1,lll,kkk,iii,2,1))
6624               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6625               call matvec2(auxmat(1,1),b1(1,itl),
6626      &          AEAb1derx(1,lll,kkk,iii,1,2))
6627               call matvec2(auxmat(1,1),Ub2(1,l),
6628      &          AEAb2derx(1,lll,kkk,iii,1,2))
6629               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6630      &          AEAb1derx(1,lll,kkk,iii,2,2))
6631               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6632      &          AEAb2derx(1,lll,kkk,iii,2,2))
6633             enddo
6634           enddo
6635         enddo
6636         ENDIF
6637 C End vectors
6638       endif
6639       return
6640       end
6641 C---------------------------------------------------------------------------
6642       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6643      &  KK,KKderg,AKA,AKAderg,AKAderx)
6644       implicit none
6645       integer nderg
6646       logical transp
6647       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6648      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6649      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6650       integer iii,kkk,lll
6651       integer jjj,mmm
6652       logical lprn
6653       common /kutas/ lprn
6654       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6655       do iii=1,nderg
6656         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6657      &    AKAderg(1,1,iii))
6658       enddo
6659 cd      if (lprn) write (2,*) 'In kernel'
6660       do kkk=1,5
6661 cd        if (lprn) write (2,*) 'kkk=',kkk
6662         do lll=1,3
6663           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6664      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6665 cd          if (lprn) then
6666 cd            write (2,*) 'lll=',lll
6667 cd            write (2,*) 'iii=1'
6668 cd            do jjj=1,2
6669 cd              write (2,'(3(2f10.5),5x)')
6670 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6671 cd            enddo
6672 cd          endif
6673           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6674      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6675 cd          if (lprn) then
6676 cd            write (2,*) 'lll=',lll
6677 cd            write (2,*) 'iii=2'
6678 cd            do jjj=1,2
6679 cd              write (2,'(3(2f10.5),5x)')
6680 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6681 cd            enddo
6682 cd          endif
6683         enddo
6684       enddo
6685       return
6686       end
6687 C---------------------------------------------------------------------------
6688       double precision function eello4(i,j,k,l,jj,kk)
6689       implicit real*8 (a-h,o-z)
6690       include 'DIMENSIONS'
6691       include 'DIMENSIONS.ZSCOPT'
6692       include 'COMMON.IOUNITS'
6693       include 'COMMON.CHAIN'
6694       include 'COMMON.DERIV'
6695       include 'COMMON.INTERACT'
6696       include 'COMMON.CONTACTS'
6697       include 'COMMON.TORSION'
6698       include 'COMMON.VAR'
6699       include 'COMMON.GEO'
6700       double precision pizda(2,2),ggg1(3),ggg2(3)
6701 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6702 cd        eello4=0.0d0
6703 cd        return
6704 cd      endif
6705 cd      print *,'eello4:',i,j,k,l,jj,kk
6706 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6707 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6708 cold      eij=facont_hb(jj,i)
6709 cold      ekl=facont_hb(kk,k)
6710 cold      ekont=eij*ekl
6711       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6712       if (calc_grad) then
6713 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6714       gcorr_loc(k-1)=gcorr_loc(k-1)
6715      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6716       if (l.eq.j+1) then
6717         gcorr_loc(l-1)=gcorr_loc(l-1)
6718      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6719       else
6720         gcorr_loc(j-1)=gcorr_loc(j-1)
6721      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6722       endif
6723       do iii=1,2
6724         do kkk=1,5
6725           do lll=1,3
6726             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6727      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6728 cd            derx(lll,kkk,iii)=0.0d0
6729           enddo
6730         enddo
6731       enddo
6732 cd      gcorr_loc(l-1)=0.0d0
6733 cd      gcorr_loc(j-1)=0.0d0
6734 cd      gcorr_loc(k-1)=0.0d0
6735 cd      eel4=1.0d0
6736 cd      write (iout,*)'Contacts have occurred for peptide groups',
6737 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6738 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6739       if (j.lt.nres-1) then
6740         j1=j+1
6741         j2=j-1
6742       else
6743         j1=j-1
6744         j2=j-2
6745       endif
6746       if (l.lt.nres-1) then
6747         l1=l+1
6748         l2=l-1
6749       else
6750         l1=l-1
6751         l2=l-2
6752       endif
6753       do ll=1,3
6754 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6755         ggg1(ll)=eel4*g_contij(ll,1)
6756         ggg2(ll)=eel4*g_contij(ll,2)
6757         ghalf=0.5d0*ggg1(ll)
6758 cd        ghalf=0.0d0
6759         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6760         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6761         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6762         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6763 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6764         ghalf=0.5d0*ggg2(ll)
6765 cd        ghalf=0.0d0
6766         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6767         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6768         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6769         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6770       enddo
6771 cd      goto 1112
6772       do m=i+1,j-1
6773         do ll=1,3
6774 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6775           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6776         enddo
6777       enddo
6778       do m=k+1,l-1
6779         do ll=1,3
6780 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6781           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6782         enddo
6783       enddo
6784 1112  continue
6785       do m=i+2,j2
6786         do ll=1,3
6787           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6788         enddo
6789       enddo
6790       do m=k+2,l2
6791         do ll=1,3
6792           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6793         enddo
6794       enddo
6795 cd      do iii=1,nres-3
6796 cd        write (2,*) iii,gcorr_loc(iii)
6797 cd      enddo
6798       endif
6799       eello4=ekont*eel4
6800 cd      write (2,*) 'ekont',ekont
6801 cd      write (iout,*) 'eello4',ekont*eel4
6802       return
6803       end
6804 C---------------------------------------------------------------------------
6805       double precision function eello5(i,j,k,l,jj,kk)
6806       implicit real*8 (a-h,o-z)
6807       include 'DIMENSIONS'
6808       include 'DIMENSIONS.ZSCOPT'
6809       include 'COMMON.IOUNITS'
6810       include 'COMMON.CHAIN'
6811       include 'COMMON.DERIV'
6812       include 'COMMON.INTERACT'
6813       include 'COMMON.CONTACTS'
6814       include 'COMMON.TORSION'
6815       include 'COMMON.VAR'
6816       include 'COMMON.GEO'
6817       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6818       double precision ggg1(3),ggg2(3)
6819 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6820 C                                                                              C
6821 C                            Parallel chains                                   C
6822 C                                                                              C
6823 C          o             o                   o             o                   C
6824 C         /l\           / \             \   / \           / \   /              C
6825 C        /   \         /   \             \ /   \         /   \ /               C
6826 C       j| o |l1       | o |              o| o |         | o |o                C
6827 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6828 C      \i/   \         /   \ /             /   \         /   \                 C
6829 C       o    k1             o                                                  C
6830 C         (I)          (II)                (III)          (IV)                 C
6831 C                                                                              C
6832 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6833 C                                                                              C
6834 C                            Antiparallel chains                               C
6835 C                                                                              C
6836 C          o             o                   o             o                   C
6837 C         /j\           / \             \   / \           / \   /              C
6838 C        /   \         /   \             \ /   \         /   \ /               C
6839 C      j1| o |l        | o |              o| o |         | o |o                C
6840 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6841 C      \i/   \         /   \ /             /   \         /   \                 C
6842 C       o     k1            o                                                  C
6843 C         (I)          (II)                (III)          (IV)                 C
6844 C                                                                              C
6845 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6846 C                                                                              C
6847 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6848 C                                                                              C
6849 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6850 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6851 cd        eello5=0.0d0
6852 cd        return
6853 cd      endif
6854 cd      write (iout,*)
6855 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6856 cd     &   ' and',k,l
6857       itk=itortyp(itype(k))
6858       itl=itortyp(itype(l))
6859       itj=itortyp(itype(j))
6860       eello5_1=0.0d0
6861       eello5_2=0.0d0
6862       eello5_3=0.0d0
6863       eello5_4=0.0d0
6864 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6865 cd     &   eel5_3_num,eel5_4_num)
6866       do iii=1,2
6867         do kkk=1,5
6868           do lll=1,3
6869             derx(lll,kkk,iii)=0.0d0
6870           enddo
6871         enddo
6872       enddo
6873 cd      eij=facont_hb(jj,i)
6874 cd      ekl=facont_hb(kk,k)
6875 cd      ekont=eij*ekl
6876 cd      write (iout,*)'Contacts have occurred for peptide groups',
6877 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6878 cd      goto 1111
6879 C Contribution from the graph I.
6880 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6881 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6882       call transpose2(EUg(1,1,k),auxmat(1,1))
6883       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6884       vv(1)=pizda(1,1)-pizda(2,2)
6885       vv(2)=pizda(1,2)+pizda(2,1)
6886       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6887      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6888       if (calc_grad) then
6889 C Explicit gradient in virtual-dihedral angles.
6890       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6891      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6892      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6893       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6894       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6895       vv(1)=pizda(1,1)-pizda(2,2)
6896       vv(2)=pizda(1,2)+pizda(2,1)
6897       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6898      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6899      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6900       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6901       vv(1)=pizda(1,1)-pizda(2,2)
6902       vv(2)=pizda(1,2)+pizda(2,1)
6903       if (l.eq.j+1) then
6904         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6905      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6906      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6907       else
6908         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6909      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6910      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6911       endif
6912 C Cartesian gradient
6913       do iii=1,2
6914         do kkk=1,5
6915           do lll=1,3
6916             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6917      &        pizda(1,1))
6918             vv(1)=pizda(1,1)-pizda(2,2)
6919             vv(2)=pizda(1,2)+pizda(2,1)
6920             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6921      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6922      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6923           enddo
6924         enddo
6925       enddo
6926 c      goto 1112
6927       endif
6928 c1111  continue
6929 C Contribution from graph II
6930       call transpose2(EE(1,1,itk),auxmat(1,1))
6931       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6932       vv(1)=pizda(1,1)+pizda(2,2)
6933       vv(2)=pizda(2,1)-pizda(1,2)
6934       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6935      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6936       if (calc_grad) then
6937 C Explicit gradient in virtual-dihedral angles.
6938       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6939      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6940       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6941       vv(1)=pizda(1,1)+pizda(2,2)
6942       vv(2)=pizda(2,1)-pizda(1,2)
6943       if (l.eq.j+1) then
6944         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6945      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6946      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6947       else
6948         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6949      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6950      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6951       endif
6952 C Cartesian gradient
6953       do iii=1,2
6954         do kkk=1,5
6955           do lll=1,3
6956             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6957      &        pizda(1,1))
6958             vv(1)=pizda(1,1)+pizda(2,2)
6959             vv(2)=pizda(2,1)-pizda(1,2)
6960             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6961      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6962      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6963           enddo
6964         enddo
6965       enddo
6966 cd      goto 1112
6967       endif
6968 cd1111  continue
6969       if (l.eq.j+1) then
6970 cd        goto 1110
6971 C Parallel orientation
6972 C Contribution from graph III
6973         call transpose2(EUg(1,1,l),auxmat(1,1))
6974         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6975         vv(1)=pizda(1,1)-pizda(2,2)
6976         vv(2)=pizda(1,2)+pizda(2,1)
6977         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6978      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6979         if (calc_grad) then
6980 C Explicit gradient in virtual-dihedral angles.
6981         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6982      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6983      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6984         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6985         vv(1)=pizda(1,1)-pizda(2,2)
6986         vv(2)=pizda(1,2)+pizda(2,1)
6987         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6988      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6989      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6990         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6991         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6992         vv(1)=pizda(1,1)-pizda(2,2)
6993         vv(2)=pizda(1,2)+pizda(2,1)
6994         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6995      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6996      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6997 C Cartesian gradient
6998         do iii=1,2
6999           do kkk=1,5
7000             do lll=1,3
7001               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7002      &          pizda(1,1))
7003               vv(1)=pizda(1,1)-pizda(2,2)
7004               vv(2)=pizda(1,2)+pizda(2,1)
7005               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7006      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7007      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7008             enddo
7009           enddo
7010         enddo
7011 cd        goto 1112
7012         endif
7013 C Contribution from graph IV
7014 cd1110    continue
7015         call transpose2(EE(1,1,itl),auxmat(1,1))
7016         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7017         vv(1)=pizda(1,1)+pizda(2,2)
7018         vv(2)=pizda(2,1)-pizda(1,2)
7019         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7020      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7021         if (calc_grad) then
7022 C Explicit gradient in virtual-dihedral angles.
7023         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7024      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7025         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7026         vv(1)=pizda(1,1)+pizda(2,2)
7027         vv(2)=pizda(2,1)-pizda(1,2)
7028         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7029      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7030      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7031 C Cartesian gradient
7032         do iii=1,2
7033           do kkk=1,5
7034             do lll=1,3
7035               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7036      &          pizda(1,1))
7037               vv(1)=pizda(1,1)+pizda(2,2)
7038               vv(2)=pizda(2,1)-pizda(1,2)
7039               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7040      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7041      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7042             enddo
7043           enddo
7044         enddo
7045         endif
7046       else
7047 C Antiparallel orientation
7048 C Contribution from graph III
7049 c        goto 1110
7050         call transpose2(EUg(1,1,j),auxmat(1,1))
7051         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7052         vv(1)=pizda(1,1)-pizda(2,2)
7053         vv(2)=pizda(1,2)+pizda(2,1)
7054         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7055      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7056         if (calc_grad) then
7057 C Explicit gradient in virtual-dihedral angles.
7058         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7059      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7060      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7061         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7062         vv(1)=pizda(1,1)-pizda(2,2)
7063         vv(2)=pizda(1,2)+pizda(2,1)
7064         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7065      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7066      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7067         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7068         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7069         vv(1)=pizda(1,1)-pizda(2,2)
7070         vv(2)=pizda(1,2)+pizda(2,1)
7071         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7072      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7073      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7074 C Cartesian gradient
7075         do iii=1,2
7076           do kkk=1,5
7077             do lll=1,3
7078               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7079      &          pizda(1,1))
7080               vv(1)=pizda(1,1)-pizda(2,2)
7081               vv(2)=pizda(1,2)+pizda(2,1)
7082               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7083      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7084      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7085             enddo
7086           enddo
7087         enddo
7088 cd        goto 1112
7089         endif
7090 C Contribution from graph IV
7091 1110    continue
7092         call transpose2(EE(1,1,itj),auxmat(1,1))
7093         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7094         vv(1)=pizda(1,1)+pizda(2,2)
7095         vv(2)=pizda(2,1)-pizda(1,2)
7096         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7097      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7098         if (calc_grad) then
7099 C Explicit gradient in virtual-dihedral angles.
7100         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7101      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7102         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7103         vv(1)=pizda(1,1)+pizda(2,2)
7104         vv(2)=pizda(2,1)-pizda(1,2)
7105         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7106      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7107      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7108 C Cartesian gradient
7109         do iii=1,2
7110           do kkk=1,5
7111             do lll=1,3
7112               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7113      &          pizda(1,1))
7114               vv(1)=pizda(1,1)+pizda(2,2)
7115               vv(2)=pizda(2,1)-pizda(1,2)
7116               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7117      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7118      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7119             enddo
7120           enddo
7121         enddo
7122       endif
7123       endif
7124 1112  continue
7125       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7126 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7127 cd        write (2,*) 'ijkl',i,j,k,l
7128 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7129 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7130 cd      endif
7131 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7132 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7133 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7134 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7135       if (calc_grad) then
7136       if (j.lt.nres-1) then
7137         j1=j+1
7138         j2=j-1
7139       else
7140         j1=j-1
7141         j2=j-2
7142       endif
7143       if (l.lt.nres-1) then
7144         l1=l+1
7145         l2=l-1
7146       else
7147         l1=l-1
7148         l2=l-2
7149       endif
7150 cd      eij=1.0d0
7151 cd      ekl=1.0d0
7152 cd      ekont=1.0d0
7153 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7154       do ll=1,3
7155         ggg1(ll)=eel5*g_contij(ll,1)
7156         ggg2(ll)=eel5*g_contij(ll,2)
7157 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7158         ghalf=0.5d0*ggg1(ll)
7159 cd        ghalf=0.0d0
7160         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7161         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7162         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7163         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7164 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7165         ghalf=0.5d0*ggg2(ll)
7166 cd        ghalf=0.0d0
7167         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7168         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7169         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7170         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7171       enddo
7172 cd      goto 1112
7173       do m=i+1,j-1
7174         do ll=1,3
7175 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7176           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7177         enddo
7178       enddo
7179       do m=k+1,l-1
7180         do ll=1,3
7181 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7182           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7183         enddo
7184       enddo
7185 c1112  continue
7186       do m=i+2,j2
7187         do ll=1,3
7188           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7189         enddo
7190       enddo
7191       do m=k+2,l2
7192         do ll=1,3
7193           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7194         enddo
7195       enddo
7196 cd      do iii=1,nres-3
7197 cd        write (2,*) iii,g_corr5_loc(iii)
7198 cd      enddo
7199       endif
7200       eello5=ekont*eel5
7201 cd      write (2,*) 'ekont',ekont
7202 cd      write (iout,*) 'eello5',ekont*eel5
7203       return
7204       end
7205 c--------------------------------------------------------------------------
7206       double precision function eello6(i,j,k,l,jj,kk)
7207       implicit real*8 (a-h,o-z)
7208       include 'DIMENSIONS'
7209       include 'DIMENSIONS.ZSCOPT'
7210       include 'COMMON.IOUNITS'
7211       include 'COMMON.CHAIN'
7212       include 'COMMON.DERIV'
7213       include 'COMMON.INTERACT'
7214       include 'COMMON.CONTACTS'
7215       include 'COMMON.TORSION'
7216       include 'COMMON.VAR'
7217       include 'COMMON.GEO'
7218       include 'COMMON.FFIELD'
7219       double precision ggg1(3),ggg2(3)
7220 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7221 cd        eello6=0.0d0
7222 cd        return
7223 cd      endif
7224 cd      write (iout,*)
7225 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7226 cd     &   ' and',k,l
7227       eello6_1=0.0d0
7228       eello6_2=0.0d0
7229       eello6_3=0.0d0
7230       eello6_4=0.0d0
7231       eello6_5=0.0d0
7232       eello6_6=0.0d0
7233 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7234 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7235       do iii=1,2
7236         do kkk=1,5
7237           do lll=1,3
7238             derx(lll,kkk,iii)=0.0d0
7239           enddo
7240         enddo
7241       enddo
7242 cd      eij=facont_hb(jj,i)
7243 cd      ekl=facont_hb(kk,k)
7244 cd      ekont=eij*ekl
7245 cd      eij=1.0d0
7246 cd      ekl=1.0d0
7247 cd      ekont=1.0d0
7248       if (l.eq.j+1) then
7249         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7250         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7251         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7252         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7253         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7254         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7255       else
7256         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7257         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7258         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7259         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7260         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7261           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7262         else
7263           eello6_5=0.0d0
7264         endif
7265         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7266       endif
7267 C If turn contributions are considered, they will be handled separately.
7268       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7269 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7270 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7271 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7272 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7273 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7274 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7275 cd      goto 1112
7276       if (calc_grad) then
7277       if (j.lt.nres-1) then
7278         j1=j+1
7279         j2=j-1
7280       else
7281         j1=j-1
7282         j2=j-2
7283       endif
7284       if (l.lt.nres-1) then
7285         l1=l+1
7286         l2=l-1
7287       else
7288         l1=l-1
7289         l2=l-2
7290       endif
7291       do ll=1,3
7292         ggg1(ll)=eel6*g_contij(ll,1)
7293         ggg2(ll)=eel6*g_contij(ll,2)
7294 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7295         ghalf=0.5d0*ggg1(ll)
7296 cd        ghalf=0.0d0
7297         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7298         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7299         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7300         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7301         ghalf=0.5d0*ggg2(ll)
7302 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7303 cd        ghalf=0.0d0
7304         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7305         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7306         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7307         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7308       enddo
7309 cd      goto 1112
7310       do m=i+1,j-1
7311         do ll=1,3
7312 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7313           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7314         enddo
7315       enddo
7316       do m=k+1,l-1
7317         do ll=1,3
7318 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7319           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7320         enddo
7321       enddo
7322 1112  continue
7323       do m=i+2,j2
7324         do ll=1,3
7325           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7326         enddo
7327       enddo
7328       do m=k+2,l2
7329         do ll=1,3
7330           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7331         enddo
7332       enddo
7333 cd      do iii=1,nres-3
7334 cd        write (2,*) iii,g_corr6_loc(iii)
7335 cd      enddo
7336       endif
7337       eello6=ekont*eel6
7338 cd      write (2,*) 'ekont',ekont
7339 cd      write (iout,*) 'eello6',ekont*eel6
7340       return
7341       end
7342 c--------------------------------------------------------------------------
7343       double precision function eello6_graph1(i,j,k,l,imat,swap)
7344       implicit real*8 (a-h,o-z)
7345       include 'DIMENSIONS'
7346       include 'DIMENSIONS.ZSCOPT'
7347       include 'COMMON.IOUNITS'
7348       include 'COMMON.CHAIN'
7349       include 'COMMON.DERIV'
7350       include 'COMMON.INTERACT'
7351       include 'COMMON.CONTACTS'
7352       include 'COMMON.TORSION'
7353       include 'COMMON.VAR'
7354       include 'COMMON.GEO'
7355       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7356       logical swap
7357       logical lprn
7358       common /kutas/ lprn
7359 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7360 C                                                                              C
7361 C      Parallel       Antiparallel                                             C
7362 C                                                                              C
7363 C          o             o                                                     C
7364 C         /l\           /j\                                                    C
7365 C        /   \         /   \                                                   C
7366 C       /| o |         | o |\                                                  C
7367 C     \ j|/k\|  /   \  |/k\|l /                                                C
7368 C      \ /   \ /     \ /   \ /                                                 C
7369 C       o     o       o     o                                                  C
7370 C       i             i                                                        C
7371 C                                                                              C
7372 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7373       itk=itortyp(itype(k))
7374       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7375       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7376       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7377       call transpose2(EUgC(1,1,k),auxmat(1,1))
7378       call matmat2(AEA(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       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7382       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7383       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7384       s5=scalar2(vv(1),Dtobr2(1,i))
7385 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7386       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7387       if (.not. calc_grad) return
7388       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7389      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7390      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7391      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7392      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7393      & +scalar2(vv(1),Dtobr2der(1,i)))
7394       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7395       vv1(1)=pizda1(1,1)-pizda1(2,2)
7396       vv1(2)=pizda1(1,2)+pizda1(2,1)
7397       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7398       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7399       if (l.eq.j+1) then
7400         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7401      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7402      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7403      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7404      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7405       else
7406         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7407      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7408      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7409      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7410      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7411       endif
7412       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7413       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7414       vv1(1)=pizda1(1,1)-pizda1(2,2)
7415       vv1(2)=pizda1(1,2)+pizda1(2,1)
7416       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7417      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7418      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7419      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7420       do iii=1,2
7421         if (swap) then
7422           ind=3-iii
7423         else
7424           ind=iii
7425         endif
7426         do kkk=1,5
7427           do lll=1,3
7428             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7429             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7430             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7431             call transpose2(EUgC(1,1,k),auxmat(1,1))
7432             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7433      &        pizda1(1,1))
7434             vv1(1)=pizda1(1,1)-pizda1(2,2)
7435             vv1(2)=pizda1(1,2)+pizda1(2,1)
7436             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7437             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7438      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7439             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7440      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7441             s5=scalar2(vv(1),Dtobr2(1,i))
7442             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7443           enddo
7444         enddo
7445       enddo
7446       return
7447       end
7448 c----------------------------------------------------------------------------
7449       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7450       implicit real*8 (a-h,o-z)
7451       include 'DIMENSIONS'
7452       include 'DIMENSIONS.ZSCOPT'
7453       include 'COMMON.IOUNITS'
7454       include 'COMMON.CHAIN'
7455       include 'COMMON.DERIV'
7456       include 'COMMON.INTERACT'
7457       include 'COMMON.CONTACTS'
7458       include 'COMMON.TORSION'
7459       include 'COMMON.VAR'
7460       include 'COMMON.GEO'
7461       logical swap
7462       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7463      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7464       logical lprn
7465       common /kutas/ lprn
7466 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7467 C                                                                              C
7468 C      Parallel       Antiparallel                                             C
7469 C                                                                              C
7470 C          o             o                                                     C
7471 C     \   /l\           /j\   /                                                C
7472 C      \ /   \         /   \ /                                                 C
7473 C       o| o |         | o |o                                                  C
7474 C     \ j|/k\|      \  |/k\|l                                                  C
7475 C      \ /   \       \ /   \                                                   C
7476 C       o             o                                                        C
7477 C       i             i                                                        C
7478 C                                                                              C
7479 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7480 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7481 C AL 7/4/01 s1 would occur in the sixth-order moment,
7482 C           but not in a cluster cumulant
7483 #ifdef MOMENT
7484       s1=dip(1,jj,i)*dip(1,kk,k)
7485 #endif
7486       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7487       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7488       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7489       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7490       call transpose2(EUg(1,1,k),auxmat(1,1))
7491       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7492       vv(1)=pizda(1,1)-pizda(2,2)
7493       vv(2)=pizda(1,2)+pizda(2,1)
7494       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7495 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7496 #ifdef MOMENT
7497       eello6_graph2=-(s1+s2+s3+s4)
7498 #else
7499       eello6_graph2=-(s2+s3+s4)
7500 #endif
7501 c      eello6_graph2=-s3
7502       if (.not. calc_grad) return
7503 C Derivatives in gamma(i-1)
7504       if (i.gt.1) then
7505 #ifdef MOMENT
7506         s1=dipderg(1,jj,i)*dip(1,kk,k)
7507 #endif
7508         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7509         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7510         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7511         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7512 #ifdef MOMENT
7513         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7514 #else
7515         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7516 #endif
7517 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7518       endif
7519 C Derivatives in gamma(k-1)
7520 #ifdef MOMENT
7521       s1=dip(1,jj,i)*dipderg(1,kk,k)
7522 #endif
7523       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7524       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7525       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7526       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7527       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7528       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7529       vv(1)=pizda(1,1)-pizda(2,2)
7530       vv(2)=pizda(1,2)+pizda(2,1)
7531       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7532 #ifdef MOMENT
7533       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7534 #else
7535       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7536 #endif
7537 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7538 C Derivatives in gamma(j-1) or gamma(l-1)
7539       if (j.gt.1) then
7540 #ifdef MOMENT
7541         s1=dipderg(3,jj,i)*dip(1,kk,k)
7542 #endif
7543         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7544         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7545         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7546         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7547         vv(1)=pizda(1,1)-pizda(2,2)
7548         vv(2)=pizda(1,2)+pizda(2,1)
7549         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7550 #ifdef MOMENT
7551         if (swap) then
7552           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7553         else
7554           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7555         endif
7556 #endif
7557         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7558 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7559       endif
7560 C Derivatives in gamma(l-1) or gamma(j-1)
7561       if (l.gt.1) then
7562 #ifdef MOMENT
7563         s1=dip(1,jj,i)*dipderg(3,kk,k)
7564 #endif
7565         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7566         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7567         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7568         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7569         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7570         vv(1)=pizda(1,1)-pizda(2,2)
7571         vv(2)=pizda(1,2)+pizda(2,1)
7572         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7573 #ifdef MOMENT
7574         if (swap) then
7575           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7576         else
7577           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7578         endif
7579 #endif
7580         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7581 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7582       endif
7583 C Cartesian derivatives.
7584       if (lprn) then
7585         write (2,*) 'In eello6_graph2'
7586         do iii=1,2
7587           write (2,*) 'iii=',iii
7588           do kkk=1,5
7589             write (2,*) 'kkk=',kkk
7590             do jjj=1,2
7591               write (2,'(3(2f10.5),5x)')
7592      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7593             enddo
7594           enddo
7595         enddo
7596       endif
7597       do iii=1,2
7598         do kkk=1,5
7599           do lll=1,3
7600 #ifdef MOMENT
7601             if (iii.eq.1) then
7602               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7603             else
7604               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7605             endif
7606 #endif
7607             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7608      &        auxvec(1))
7609             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7610             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7611      &        auxvec(1))
7612             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7613             call transpose2(EUg(1,1,k),auxmat(1,1))
7614             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7615      &        pizda(1,1))
7616             vv(1)=pizda(1,1)-pizda(2,2)
7617             vv(2)=pizda(1,2)+pizda(2,1)
7618             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7619 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7620 #ifdef MOMENT
7621             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7622 #else
7623             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7624 #endif
7625             if (swap) then
7626               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7627             else
7628               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7629             endif
7630           enddo
7631         enddo
7632       enddo
7633       return
7634       end
7635 c----------------------------------------------------------------------------
7636       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7637       implicit real*8 (a-h,o-z)
7638       include 'DIMENSIONS'
7639       include 'DIMENSIONS.ZSCOPT'
7640       include 'COMMON.IOUNITS'
7641       include 'COMMON.CHAIN'
7642       include 'COMMON.DERIV'
7643       include 'COMMON.INTERACT'
7644       include 'COMMON.CONTACTS'
7645       include 'COMMON.TORSION'
7646       include 'COMMON.VAR'
7647       include 'COMMON.GEO'
7648       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7649       logical swap
7650 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7651 C                                                                              C
7652 C      Parallel       Antiparallel                                             C
7653 C                                                                              C
7654 C          o             o                                                     C
7655 C         /l\   /   \   /j\                                                    C
7656 C        /   \ /     \ /   \                                                   C
7657 C       /| o |o       o| o |\                                                  C
7658 C       j|/k\|  /      |/k\|l /                                                C
7659 C        /   \ /       /   \ /                                                 C
7660 C       /     o       /     o                                                  C
7661 C       i             i                                                        C
7662 C                                                                              C
7663 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7664 C
7665 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7666 C           energy moment and not to the cluster cumulant.
7667       iti=itortyp(itype(i))
7668       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7669         itj1=itortyp(itype(j+1))
7670       else
7671         itj1=ntortyp+1
7672       endif
7673       itk=itortyp(itype(k))
7674       itk1=itortyp(itype(k+1))
7675       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7676         itl1=itortyp(itype(l+1))
7677       else
7678         itl1=ntortyp+1
7679       endif
7680 #ifdef MOMENT
7681       s1=dip(4,jj,i)*dip(4,kk,k)
7682 #endif
7683       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7684       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7685       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7686       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7687       call transpose2(EE(1,1,itk),auxmat(1,1))
7688       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7689       vv(1)=pizda(1,1)+pizda(2,2)
7690       vv(2)=pizda(2,1)-pizda(1,2)
7691       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7692 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7693 #ifdef MOMENT
7694       eello6_graph3=-(s1+s2+s3+s4)
7695 #else
7696       eello6_graph3=-(s2+s3+s4)
7697 #endif
7698 c      eello6_graph3=-s4
7699       if (.not. calc_grad) return
7700 C Derivatives in gamma(k-1)
7701       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7702       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7703       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7704       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7705 C Derivatives in gamma(l-1)
7706       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7707       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7708       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7709       vv(1)=pizda(1,1)+pizda(2,2)
7710       vv(2)=pizda(2,1)-pizda(1,2)
7711       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7712       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7713 C Cartesian derivatives.
7714       do iii=1,2
7715         do kkk=1,5
7716           do lll=1,3
7717 #ifdef MOMENT
7718             if (iii.eq.1) then
7719               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7720             else
7721               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7722             endif
7723 #endif
7724             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7725      &        auxvec(1))
7726             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7727             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7728      &        auxvec(1))
7729             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7730             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7731      &        pizda(1,1))
7732             vv(1)=pizda(1,1)+pizda(2,2)
7733             vv(2)=pizda(2,1)-pizda(1,2)
7734             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7735 #ifdef MOMENT
7736             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7737 #else
7738             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7739 #endif
7740             if (swap) then
7741               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7742             else
7743               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7744             endif
7745 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7746           enddo
7747         enddo
7748       enddo
7749       return
7750       end
7751 c----------------------------------------------------------------------------
7752       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7753       implicit real*8 (a-h,o-z)
7754       include 'DIMENSIONS'
7755       include 'DIMENSIONS.ZSCOPT'
7756       include 'COMMON.IOUNITS'
7757       include 'COMMON.CHAIN'
7758       include 'COMMON.DERIV'
7759       include 'COMMON.INTERACT'
7760       include 'COMMON.CONTACTS'
7761       include 'COMMON.TORSION'
7762       include 'COMMON.VAR'
7763       include 'COMMON.GEO'
7764       include 'COMMON.FFIELD'
7765       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7766      & auxvec1(2),auxmat1(2,2)
7767       logical swap
7768 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7769 C                                                                              C
7770 C      Parallel       Antiparallel                                             C
7771 C                                                                              C
7772 C          o             o                                                     C
7773 C         /l\   /   \   /j\                                                    C
7774 C        /   \ /     \ /   \                                                   C
7775 C       /| o |o       o| o |\                                                  C
7776 C     \ j|/k\|      \  |/k\|l                                                  C
7777 C      \ /   \       \ /   \                                                   C
7778 C       o     \       o     \                                                  C
7779 C       i             i                                                        C
7780 C                                                                              C
7781 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7782 C
7783 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7784 C           energy moment and not to the cluster cumulant.
7785 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7786       iti=itortyp(itype(i))
7787       itj=itortyp(itype(j))
7788       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7789         itj1=itortyp(itype(j+1))
7790       else
7791         itj1=ntortyp+1
7792       endif
7793       itk=itortyp(itype(k))
7794       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7795         itk1=itortyp(itype(k+1))
7796       else
7797         itk1=ntortyp+1
7798       endif
7799       itl=itortyp(itype(l))
7800       if (l.lt.nres-1) then
7801         itl1=itortyp(itype(l+1))
7802       else
7803         itl1=ntortyp+1
7804       endif
7805 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7806 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7807 cd     & ' itl',itl,' itl1',itl1
7808 #ifdef MOMENT
7809       if (imat.eq.1) then
7810         s1=dip(3,jj,i)*dip(3,kk,k)
7811       else
7812         s1=dip(2,jj,j)*dip(2,kk,l)
7813       endif
7814 #endif
7815       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7816       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7817       if (j.eq.l+1) then
7818         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7819         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7820       else
7821         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7822         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7823       endif
7824       call transpose2(EUg(1,1,k),auxmat(1,1))
7825       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7826       vv(1)=pizda(1,1)-pizda(2,2)
7827       vv(2)=pizda(2,1)+pizda(1,2)
7828       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7829 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7830 #ifdef MOMENT
7831       eello6_graph4=-(s1+s2+s3+s4)
7832 #else
7833       eello6_graph4=-(s2+s3+s4)
7834 #endif
7835       if (.not. calc_grad) return
7836 C Derivatives in gamma(i-1)
7837       if (i.gt.1) then
7838 #ifdef MOMENT
7839         if (imat.eq.1) then
7840           s1=dipderg(2,jj,i)*dip(3,kk,k)
7841         else
7842           s1=dipderg(4,jj,j)*dip(2,kk,l)
7843         endif
7844 #endif
7845         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7846         if (j.eq.l+1) then
7847           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7848           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7849         else
7850           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7851           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7852         endif
7853         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7854         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7855 cd          write (2,*) 'turn6 derivatives'
7856 #ifdef MOMENT
7857           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7858 #else
7859           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7860 #endif
7861         else
7862 #ifdef MOMENT
7863           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7864 #else
7865           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7866 #endif
7867         endif
7868       endif
7869 C Derivatives in gamma(k-1)
7870 #ifdef MOMENT
7871       if (imat.eq.1) then
7872         s1=dip(3,jj,i)*dipderg(2,kk,k)
7873       else
7874         s1=dip(2,jj,j)*dipderg(4,kk,l)
7875       endif
7876 #endif
7877       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7878       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7879       if (j.eq.l+1) then
7880         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7881         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7882       else
7883         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7884         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7885       endif
7886       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7887       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7888       vv(1)=pizda(1,1)-pizda(2,2)
7889       vv(2)=pizda(2,1)+pizda(1,2)
7890       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7891       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7892 #ifdef MOMENT
7893         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7894 #else
7895         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7896 #endif
7897       else
7898 #ifdef MOMENT
7899         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7900 #else
7901         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7902 #endif
7903       endif
7904 C Derivatives in gamma(j-1) or gamma(l-1)
7905       if (l.eq.j+1 .and. l.gt.1) then
7906         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7907         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7908         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7909         vv(1)=pizda(1,1)-pizda(2,2)
7910         vv(2)=pizda(2,1)+pizda(1,2)
7911         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7912         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7913       else if (j.gt.1) then
7914         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7915         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7916         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7917         vv(1)=pizda(1,1)-pizda(2,2)
7918         vv(2)=pizda(2,1)+pizda(1,2)
7919         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7920         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7921           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7922         else
7923           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7924         endif
7925       endif
7926 C Cartesian derivatives.
7927       do iii=1,2
7928         do kkk=1,5
7929           do lll=1,3
7930 #ifdef MOMENT
7931             if (iii.eq.1) then
7932               if (imat.eq.1) then
7933                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7934               else
7935                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7936               endif
7937             else
7938               if (imat.eq.1) then
7939                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7940               else
7941                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7942               endif
7943             endif
7944 #endif
7945             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7946      &        auxvec(1))
7947             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7948             if (j.eq.l+1) then
7949               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7950      &          b1(1,itj1),auxvec(1))
7951               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7952             else
7953               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7954      &          b1(1,itl1),auxvec(1))
7955               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7956             endif
7957             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7958      &        pizda(1,1))
7959             vv(1)=pizda(1,1)-pizda(2,2)
7960             vv(2)=pizda(2,1)+pizda(1,2)
7961             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7962             if (swap) then
7963               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7964 #ifdef MOMENT
7965                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7966      &             -(s1+s2+s4)
7967 #else
7968                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7969      &             -(s2+s4)
7970 #endif
7971                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7972               else
7973 #ifdef MOMENT
7974                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7975 #else
7976                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7977 #endif
7978                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7979               endif
7980             else
7981 #ifdef MOMENT
7982               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7983 #else
7984               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7985 #endif
7986               if (l.eq.j+1) then
7987                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7988               else
7989                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7990               endif
7991             endif
7992           enddo
7993         enddo
7994       enddo
7995       return
7996       end
7997 c----------------------------------------------------------------------------
7998       double precision function eello_turn6(i,jj,kk)
7999       implicit real*8 (a-h,o-z)
8000       include 'DIMENSIONS'
8001       include 'DIMENSIONS.ZSCOPT'
8002       include 'COMMON.IOUNITS'
8003       include 'COMMON.CHAIN'
8004       include 'COMMON.DERIV'
8005       include 'COMMON.INTERACT'
8006       include 'COMMON.CONTACTS'
8007       include 'COMMON.TORSION'
8008       include 'COMMON.VAR'
8009       include 'COMMON.GEO'
8010       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8011      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8012      &  ggg1(3),ggg2(3)
8013       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8014      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8015 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8016 C           the respective energy moment and not to the cluster cumulant.
8017       eello_turn6=0.0d0
8018       j=i+4
8019       k=i+1
8020       l=i+3
8021       iti=itortyp(itype(i))
8022       itk=itortyp(itype(k))
8023       itk1=itortyp(itype(k+1))
8024       itl=itortyp(itype(l))
8025       itj=itortyp(itype(j))
8026 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8027 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8028 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8029 cd        eello6=0.0d0
8030 cd        return
8031 cd      endif
8032 cd      write (iout,*)
8033 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8034 cd     &   ' and',k,l
8035 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8036       do iii=1,2
8037         do kkk=1,5
8038           do lll=1,3
8039             derx_turn(lll,kkk,iii)=0.0d0
8040           enddo
8041         enddo
8042       enddo
8043 cd      eij=1.0d0
8044 cd      ekl=1.0d0
8045 cd      ekont=1.0d0
8046       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8047 cd      eello6_5=0.0d0
8048 cd      write (2,*) 'eello6_5',eello6_5
8049 #ifdef MOMENT
8050       call transpose2(AEA(1,1,1),auxmat(1,1))
8051       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8052       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8053       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8054 #else
8055       s1 = 0.0d0
8056 #endif
8057       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8058       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8059       s2 = scalar2(b1(1,itk),vtemp1(1))
8060 #ifdef MOMENT
8061       call transpose2(AEA(1,1,2),atemp(1,1))
8062       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8063       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8064       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8065 #else
8066       s8=0.0d0
8067 #endif
8068       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8069       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8070       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8071 #ifdef MOMENT
8072       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8073       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8074       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8075       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8076       ss13 = scalar2(b1(1,itk),vtemp4(1))
8077       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8078 #else
8079       s13=0.0d0
8080 #endif
8081 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8082 c      s1=0.0d0
8083 c      s2=0.0d0
8084 c      s8=0.0d0
8085 c      s12=0.0d0
8086 c      s13=0.0d0
8087       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8088       if (calc_grad) then
8089 C Derivatives in gamma(i+2)
8090 #ifdef MOMENT
8091       call transpose2(AEA(1,1,1),auxmatd(1,1))
8092       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8093       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8094       call transpose2(AEAderg(1,1,2),atempd(1,1))
8095       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8096       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8097 #else
8098       s8d=0.0d0
8099 #endif
8100       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8101       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8102       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8103 c      s1d=0.0d0
8104 c      s2d=0.0d0
8105 c      s8d=0.0d0
8106 c      s12d=0.0d0
8107 c      s13d=0.0d0
8108       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8109 C Derivatives in gamma(i+3)
8110 #ifdef MOMENT
8111       call transpose2(AEA(1,1,1),auxmatd(1,1))
8112       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8113       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8114       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8115 #else
8116       s1d=0.0d0
8117 #endif
8118       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8119       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8120       s2d = scalar2(b1(1,itk),vtemp1d(1))
8121 #ifdef MOMENT
8122       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8123       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8124 #endif
8125       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8126 #ifdef MOMENT
8127       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8128       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8129       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8130 #else
8131       s13d=0.0d0
8132 #endif
8133 c      s1d=0.0d0
8134 c      s2d=0.0d0
8135 c      s8d=0.0d0
8136 c      s12d=0.0d0
8137 c      s13d=0.0d0
8138 #ifdef MOMENT
8139       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8140      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8141 #else
8142       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8143      &               -0.5d0*ekont*(s2d+s12d)
8144 #endif
8145 C Derivatives in gamma(i+4)
8146       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8147       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8148       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8149 #ifdef MOMENT
8150       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8151       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8152       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8153 #else
8154       s13d = 0.0d0
8155 #endif
8156 c      s1d=0.0d0
8157 c      s2d=0.0d0
8158 c      s8d=0.0d0
8159 C      s12d=0.0d0
8160 c      s13d=0.0d0
8161 #ifdef MOMENT
8162       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8163 #else
8164       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8165 #endif
8166 C Derivatives in gamma(i+5)
8167 #ifdef MOMENT
8168       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8169       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8170       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8171 #else
8172       s1d = 0.0d0
8173 #endif
8174       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8175       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8176       s2d = scalar2(b1(1,itk),vtemp1d(1))
8177 #ifdef MOMENT
8178       call transpose2(AEA(1,1,2),atempd(1,1))
8179       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8180       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8181 #else
8182       s8d = 0.0d0
8183 #endif
8184       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8185       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8186 #ifdef MOMENT
8187       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8188       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8189       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8190 #else
8191       s13d = 0.0d0
8192 #endif
8193 c      s1d=0.0d0
8194 c      s2d=0.0d0
8195 c      s8d=0.0d0
8196 c      s12d=0.0d0
8197 c      s13d=0.0d0
8198 #ifdef MOMENT
8199       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8200      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8201 #else
8202       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8203      &               -0.5d0*ekont*(s2d+s12d)
8204 #endif
8205 C Cartesian derivatives
8206       do iii=1,2
8207         do kkk=1,5
8208           do lll=1,3
8209 #ifdef MOMENT
8210             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8211             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8212             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8213 #else
8214             s1d = 0.0d0
8215 #endif
8216             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8217             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8218      &          vtemp1d(1))
8219             s2d = scalar2(b1(1,itk),vtemp1d(1))
8220 #ifdef MOMENT
8221             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8222             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8223             s8d = -(atempd(1,1)+atempd(2,2))*
8224      &           scalar2(cc(1,1,itl),vtemp2(1))
8225 #else
8226             s8d = 0.0d0
8227 #endif
8228             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8229      &           auxmatd(1,1))
8230             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8231             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8232 c      s1d=0.0d0
8233 c      s2d=0.0d0
8234 c      s8d=0.0d0
8235 c      s12d=0.0d0
8236 c      s13d=0.0d0
8237 #ifdef MOMENT
8238             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8239      &        - 0.5d0*(s1d+s2d)
8240 #else
8241             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8242      &        - 0.5d0*s2d
8243 #endif
8244 #ifdef MOMENT
8245             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8246      &        - 0.5d0*(s8d+s12d)
8247 #else
8248             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8249      &        - 0.5d0*s12d
8250 #endif
8251           enddo
8252         enddo
8253       enddo
8254 #ifdef MOMENT
8255       do kkk=1,5
8256         do lll=1,3
8257           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8258      &      achuj_tempd(1,1))
8259           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8260           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8261           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8262           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8263           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8264      &      vtemp4d(1))
8265           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8266           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8267           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8268         enddo
8269       enddo
8270 #endif
8271 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8272 cd     &  16*eel_turn6_num
8273 cd      goto 1112
8274       if (j.lt.nres-1) then
8275         j1=j+1
8276         j2=j-1
8277       else
8278         j1=j-1
8279         j2=j-2
8280       endif
8281       if (l.lt.nres-1) then
8282         l1=l+1
8283         l2=l-1
8284       else
8285         l1=l-1
8286         l2=l-2
8287       endif
8288       do ll=1,3
8289         ggg1(ll)=eel_turn6*g_contij(ll,1)
8290         ggg2(ll)=eel_turn6*g_contij(ll,2)
8291         ghalf=0.5d0*ggg1(ll)
8292 cd        ghalf=0.0d0
8293         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8294      &    +ekont*derx_turn(ll,2,1)
8295         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8296         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8297      &    +ekont*derx_turn(ll,4,1)
8298         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8299         ghalf=0.5d0*ggg2(ll)
8300 cd        ghalf=0.0d0
8301         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8302      &    +ekont*derx_turn(ll,2,2)
8303         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8304         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8305      &    +ekont*derx_turn(ll,4,2)
8306         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8307       enddo
8308 cd      goto 1112
8309       do m=i+1,j-1
8310         do ll=1,3
8311           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8312         enddo
8313       enddo
8314       do m=k+1,l-1
8315         do ll=1,3
8316           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8317         enddo
8318       enddo
8319 1112  continue
8320       do m=i+2,j2
8321         do ll=1,3
8322           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8323         enddo
8324       enddo
8325       do m=k+2,l2
8326         do ll=1,3
8327           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8328         enddo
8329       enddo
8330 cd      do iii=1,nres-3
8331 cd        write (2,*) iii,g_corr6_loc(iii)
8332 cd      enddo
8333       endif
8334       eello_turn6=ekont*eel_turn6
8335 cd      write (2,*) 'ekont',ekont
8336 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8337       return
8338       end
8339 crc-------------------------------------------------
8340 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8341       subroutine Eliptransfer(eliptran)
8342       implicit real*8 (a-h,o-z)
8343       include 'DIMENSIONS'
8344       include 'COMMON.GEO'
8345       include 'COMMON.VAR'
8346       include 'COMMON.LOCAL'
8347       include 'COMMON.CHAIN'
8348       include 'COMMON.DERIV'
8349       include 'COMMON.INTERACT'
8350       include 'COMMON.IOUNITS'
8351       include 'COMMON.CALC'
8352       include 'COMMON.CONTROL'
8353       include 'COMMON.SPLITELE'
8354       include 'COMMON.SBRIDGE'
8355 C this is done by Adasko
8356 C      print *,"wchodze"
8357 C structure of box:
8358 C      water
8359 C--bordliptop-- buffore starts
8360 C--bufliptop--- here true lipid starts
8361 C      lipid
8362 C--buflipbot--- lipid ends buffore starts
8363 C--bordlipbot--buffore ends
8364       eliptran=0.0
8365       do i=1,nres
8366 C       do i=1,1
8367         if (itype(i).eq.ntyp1) cycle
8368
8369         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8370         if (positi.le.0) positi=positi+boxzsize
8371 C        print *,i
8372 C first for peptide groups
8373 c for each residue check if it is in lipid or lipid water border area
8374        if ((positi.gt.bordlipbot)
8375      &.and.(positi.lt.bordliptop)) then
8376 C the energy transfer exist
8377         if (positi.lt.buflipbot) then
8378 C what fraction I am in
8379          fracinbuf=1.0d0-
8380      &        ((positi-bordlipbot)/lipbufthick)
8381 C lipbufthick is thickenes of lipid buffore
8382          sslip=sscalelip(fracinbuf)
8383          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8384          eliptran=eliptran+sslip*pepliptran
8385          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8386          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8387 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8388         elseif (positi.gt.bufliptop) then
8389          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8390          sslip=sscalelip(fracinbuf)
8391          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8392          eliptran=eliptran+sslip*pepliptran
8393          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8394          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8395 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8396 C          print *, "doing sscalefor top part"
8397 C         print *,i,sslip,fracinbuf,ssgradlip
8398         else
8399          eliptran=eliptran+pepliptran
8400 C         print *,"I am in true lipid"
8401         endif
8402 C       else
8403 C       eliptran=elpitran+0.0 ! I am in water
8404        endif
8405        enddo
8406 C       print *, "nic nie bylo w lipidzie?"
8407 C now multiply all by the peptide group transfer factor
8408 C       eliptran=eliptran*pepliptran
8409 C now the same for side chains
8410 CV       do i=1,1
8411        do i=1,nres
8412         if (itype(i).eq.ntyp1) cycle
8413         positi=(mod(c(3,i+nres),boxzsize))
8414         if (positi.le.0) positi=positi+boxzsize
8415 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8416 c for each residue check if it is in lipid or lipid water border area
8417 C       respos=mod(c(3,i+nres),boxzsize)
8418 C       print *,positi,bordlipbot,buflipbot
8419        if ((positi.gt.bordlipbot)
8420      & .and.(positi.lt.bordliptop)) then
8421 C the energy transfer exist
8422         if (positi.lt.buflipbot) then
8423          fracinbuf=1.0d0-
8424      &     ((positi-bordlipbot)/lipbufthick)
8425 C lipbufthick is thickenes of lipid buffore
8426          sslip=sscalelip(fracinbuf)
8427          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8428          eliptran=eliptran+sslip*liptranene(itype(i))
8429          gliptranx(3,i)=gliptranx(3,i)
8430      &+ssgradlip*liptranene(itype(i))
8431          gliptranc(3,i-1)= gliptranc(3,i-1)
8432      &+ssgradlip*liptranene(itype(i))
8433 C         print *,"doing sccale for lower part"
8434         elseif (positi.gt.bufliptop) then
8435          fracinbuf=1.0d0-
8436      &((bordliptop-positi)/lipbufthick)
8437          sslip=sscalelip(fracinbuf)
8438          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8439          eliptran=eliptran+sslip*liptranene(itype(i))
8440          gliptranx(3,i)=gliptranx(3,i)
8441      &+ssgradlip*liptranene(itype(i))
8442          gliptranc(3,i-1)= gliptranc(3,i-1)
8443      &+ssgradlip*liptranene(itype(i))
8444 C          print *, "doing sscalefor top part",sslip,fracinbuf
8445         else
8446          eliptran=eliptran+liptranene(itype(i))
8447 C         print *,"I am in true lipid"
8448         endif
8449         endif ! if in lipid or buffor
8450 C       else
8451 C       eliptran=elpitran+0.0 ! I am in water
8452        enddo
8453        return
8454        end
8455
8456
8457 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8458
8459       SUBROUTINE MATVEC2(A1,V1,V2)
8460       implicit real*8 (a-h,o-z)
8461       include 'DIMENSIONS'
8462       DIMENSION A1(2,2),V1(2),V2(2)
8463 c      DO 1 I=1,2
8464 c        VI=0.0
8465 c        DO 3 K=1,2
8466 c    3     VI=VI+A1(I,K)*V1(K)
8467 c        Vaux(I)=VI
8468 c    1 CONTINUE
8469
8470       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8471       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8472
8473       v2(1)=vaux1
8474       v2(2)=vaux2
8475       END
8476 C---------------------------------------
8477       SUBROUTINE MATMAT2(A1,A2,A3)
8478       implicit real*8 (a-h,o-z)
8479       include 'DIMENSIONS'
8480       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8481 c      DIMENSION AI3(2,2)
8482 c        DO  J=1,2
8483 c          A3IJ=0.0
8484 c          DO K=1,2
8485 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8486 c          enddo
8487 c          A3(I,J)=A3IJ
8488 c       enddo
8489 c      enddo
8490
8491       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8492       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8493       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8494       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8495
8496       A3(1,1)=AI3_11
8497       A3(2,1)=AI3_21
8498       A3(1,2)=AI3_12
8499       A3(2,2)=AI3_22
8500       END
8501
8502 c-------------------------------------------------------------------------
8503       double precision function scalar2(u,v)
8504       implicit none
8505       double precision u(2),v(2)
8506       double precision sc
8507       integer i
8508       scalar2=u(1)*v(1)+u(2)*v(2)
8509       return
8510       end
8511
8512 C-----------------------------------------------------------------------------
8513
8514       subroutine transpose2(a,at)
8515       implicit none
8516       double precision a(2,2),at(2,2)
8517       at(1,1)=a(1,1)
8518       at(1,2)=a(2,1)
8519       at(2,1)=a(1,2)
8520       at(2,2)=a(2,2)
8521       return
8522       end
8523 c--------------------------------------------------------------------------
8524       subroutine transpose(n,a,at)
8525       implicit none
8526       integer n,i,j
8527       double precision a(n,n),at(n,n)
8528       do i=1,n
8529         do j=1,n
8530           at(j,i)=a(i,j)
8531         enddo
8532       enddo
8533       return
8534       end
8535 C---------------------------------------------------------------------------
8536       subroutine prodmat3(a1,a2,kk,transp,prod)
8537       implicit none
8538       integer i,j
8539       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8540       logical transp
8541 crc      double precision auxmat(2,2),prod_(2,2)
8542
8543       if (transp) then
8544 crc        call transpose2(kk(1,1),auxmat(1,1))
8545 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8546 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8547
8548            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8549      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8550            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8551      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8552            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8553      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8554            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8555      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8556
8557       else
8558 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8559 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8560
8561            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8562      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8563            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8564      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8565            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8566      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8567            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8568      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8569
8570       endif
8571 c      call transpose2(a2(1,1),a2t(1,1))
8572
8573 crc      print *,transp
8574 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8575 crc      print *,((prod(i,j),i=1,2),j=1,2)
8576
8577       return
8578       end
8579 C-----------------------------------------------------------------------------
8580       double precision function scalar(u,v)
8581       implicit none
8582       double precision u(3),v(3)
8583       double precision sc
8584       integer i
8585       sc=0.0d0
8586       do i=1,3
8587         sc=sc+u(i)*v(i)
8588       enddo
8589       scalar=sc
8590       return
8591       end
8592 C-----------------------------------------------------------------------
8593       double precision function sscale(r)
8594       double precision r,gamm
8595       include "COMMON.SPLITELE"
8596       if(r.lt.r_cut-rlamb) then
8597         sscale=1.0d0
8598       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8599         gamm=(r-(r_cut-rlamb))/rlamb
8600         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8601       else
8602         sscale=0d0
8603       endif
8604       return
8605       end
8606 C-----------------------------------------------------------------------
8607 C-----------------------------------------------------------------------
8608       double precision function sscagrad(r)
8609       double precision r,gamm
8610       include "COMMON.SPLITELE"
8611       if(r.lt.r_cut-rlamb) then
8612         sscagrad=0.0d0
8613       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8614         gamm=(r-(r_cut-rlamb))/rlamb
8615         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8616       else
8617         sscagrad=0.0d0
8618       endif
8619       return
8620       end
8621 C-----------------------------------------------------------------------
8622 C-----------------------------------------------------------------------
8623       double precision function sscalelip(r)
8624       double precision r,gamm
8625       include "COMMON.SPLITELE"
8626 C      if(r.lt.r_cut-rlamb) then
8627 C        sscale=1.0d0
8628 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8629 C        gamm=(r-(r_cut-rlamb))/rlamb
8630         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8631 C      else
8632 C        sscale=0d0
8633 C      endif
8634       return
8635       end
8636 C-----------------------------------------------------------------------
8637       double precision function sscagradlip(r)
8638       double precision r,gamm
8639       include "COMMON.SPLITELE"
8640 C     if(r.lt.r_cut-rlamb) then
8641 C        sscagrad=0.0d0
8642 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8643 C        gamm=(r-(r_cut-rlamb))/rlamb
8644         sscagradlip=r*(6*r-6.0d0)
8645 C      else
8646 C        sscagrad=0.0d0
8647 C      endif
8648       return
8649       end
8650
8651 C-----------------------------------------------------------------------
8652        subroutine set_shield_fac
8653       implicit real*8 (a-h,o-z)
8654       include 'DIMENSIONS'
8655       include 'COMMON.CHAIN'
8656       include 'COMMON.DERIV'
8657       include 'COMMON.IOUNITS'
8658       include 'COMMON.SHIELD'
8659       include 'COMMON.INTERACT'
8660 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8661       double precision div77_81/0.974996043d0/,
8662      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8663
8664 C the vector between center of side_chain and peptide group
8665        double precision pep_side(3),long,side_calf(3),
8666      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8667      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8668 C the line belowe needs to be changed for FGPROC>1
8669       do i=1,nres-1
8670       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8671       ishield_list(i)=0
8672 Cif there two consequtive dummy atoms there is no peptide group between them
8673 C the line below has to be changed for FGPROC>1
8674       VolumeTotal=0.0
8675       do k=1,nres
8676        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8677        dist_pep_side=0.0
8678        dist_side_calf=0.0
8679        do j=1,3
8680 C first lets set vector conecting the ithe side-chain with kth side-chain
8681       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8682 C      pep_side(j)=2.0d0
8683 C and vector conecting the side-chain with its proper calfa
8684       side_calf(j)=c(j,k+nres)-c(j,k)
8685 C      side_calf(j)=2.0d0
8686       pept_group(j)=c(j,i)-c(j,i+1)
8687 C lets have their lenght
8688       dist_pep_side=pep_side(j)**2+dist_pep_side
8689       dist_side_calf=dist_side_calf+side_calf(j)**2
8690       dist_pept_group=dist_pept_group+pept_group(j)**2
8691       enddo
8692        dist_pep_side=dsqrt(dist_pep_side)
8693        dist_pept_group=dsqrt(dist_pept_group)
8694        dist_side_calf=dsqrt(dist_side_calf)
8695       do j=1,3
8696         pep_side_norm(j)=pep_side(j)/dist_pep_side
8697         side_calf_norm(j)=dist_side_calf
8698       enddo
8699 C now sscale fraction
8700        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8701 C       print *,buff_shield,"buff"
8702 C now sscale
8703         if (sh_frac_dist.le.0.0) cycle
8704 C If we reach here it means that this side chain reaches the shielding sphere
8705 C Lets add him to the list for gradient
8706         ishield_list(i)=ishield_list(i)+1
8707 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8708 C this list is essential otherwise problem would be O3
8709         shield_list(ishield_list(i),i)=k
8710 C Lets have the sscale value
8711         if (sh_frac_dist.gt.1.0) then
8712          scale_fac_dist=1.0d0
8713          do j=1,3
8714          sh_frac_dist_grad(j)=0.0d0
8715          enddo
8716         else
8717          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8718      &                   *(2.0*sh_frac_dist-3.0d0)
8719          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8720      &                  /dist_pep_side/buff_shield*0.5
8721 C remember for the final gradient multiply sh_frac_dist_grad(j)
8722 C for side_chain by factor -2 !
8723          do j=1,3
8724          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8725 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8726 C     &                    sh_frac_dist_grad(j)
8727          enddo
8728         endif
8729 C        if ((i.eq.3).and.(k.eq.2)) then
8730 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8731 C     & ,"TU"
8732 C        endif
8733
8734 C this is what is now we have the distance scaling now volume...
8735       short=short_r_sidechain(itype(k))
8736       long=long_r_sidechain(itype(k))
8737       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8738 C now costhet_grad
8739 C       costhet=0.0d0
8740        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8741 C       costhet_fac=0.0d0
8742        do j=1,3
8743          costhet_grad(j)=costhet_fac*pep_side(j)
8744        enddo
8745 C remember for the final gradient multiply costhet_grad(j)
8746 C for side_chain by factor -2 !
8747 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8748 C pep_side0pept_group is vector multiplication
8749       pep_side0pept_group=0.0
8750       do j=1,3
8751       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8752       enddo
8753       cosalfa=(pep_side0pept_group/
8754      & (dist_pep_side*dist_side_calf))
8755       fac_alfa_sin=1.0-cosalfa**2
8756       fac_alfa_sin=dsqrt(fac_alfa_sin)
8757       rkprim=fac_alfa_sin*(long-short)+short
8758 C now costhet_grad
8759        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8760        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8761
8762        do j=1,3
8763          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8764      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8765      &*(long-short)/fac_alfa_sin*cosalfa/
8766      &((dist_pep_side*dist_side_calf))*
8767      &((side_calf(j))-cosalfa*
8768      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8769
8770         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8771      &*(long-short)/fac_alfa_sin*cosalfa
8772      &/((dist_pep_side*dist_side_calf))*
8773      &(pep_side(j)-
8774      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8775        enddo
8776
8777       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8778      &                    /VSolvSphere_div
8779      &                    *wshield
8780 C now the gradient...
8781 C grad_shield is gradient of Calfa for peptide groups
8782 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8783 C     &               costhet,cosphi
8784 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8785 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8786       do j=1,3
8787       grad_shield(j,i)=grad_shield(j,i)
8788 C gradient po skalowaniu
8789      &                +(sh_frac_dist_grad(j)
8790 C  gradient po costhet
8791      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8792      &-scale_fac_dist*(cosphi_grad_long(j))
8793      &/(1.0-cosphi) )*div77_81
8794      &*VofOverlap
8795 C grad_shield_side is Cbeta sidechain gradient
8796       grad_shield_side(j,ishield_list(i),i)=
8797      &        (sh_frac_dist_grad(j)*-2.0d0
8798      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8799      &       +scale_fac_dist*(cosphi_grad_long(j))
8800      &        *2.0d0/(1.0-cosphi))
8801      &        *div77_81*VofOverlap
8802
8803        grad_shield_loc(j,ishield_list(i),i)=
8804      &   scale_fac_dist*cosphi_grad_loc(j)
8805      &        *2.0d0/(1.0-cosphi)
8806      &        *div77_81*VofOverlap
8807       enddo
8808       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8809       enddo
8810       fac_shield(i)=VolumeTotal*div77_81+div4_81
8811 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8812       enddo
8813       return
8814       end
8815 C--------------------------------------------------------------------------
8816 C first for shielding is setting of function of side-chains
8817        subroutine set_shield_fac2
8818       implicit real*8 (a-h,o-z)
8819       include 'DIMENSIONS'
8820       include 'COMMON.CHAIN'
8821       include 'COMMON.DERIV'
8822       include 'COMMON.IOUNITS'
8823       include 'COMMON.SHIELD'
8824       include 'COMMON.INTERACT'
8825 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8826       double precision div77_81/0.974996043d0/,
8827      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8828
8829 C the vector between center of side_chain and peptide group
8830        double precision pep_side(3),long,side_calf(3),
8831      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8832      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8833 C the line belowe needs to be changed for FGPROC>1
8834       do i=1,nres-1
8835       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8836       ishield_list(i)=0
8837 Cif there two consequtive dummy atoms there is no peptide group between them
8838 C the line below has to be changed for FGPROC>1
8839       VolumeTotal=0.0
8840       do k=1,nres
8841        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8842        dist_pep_side=0.0
8843        dist_side_calf=0.0
8844        do j=1,3
8845 C first lets set vector conecting the ithe side-chain with kth side-chain
8846       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8847 C      pep_side(j)=2.0d0
8848 C and vector conecting the side-chain with its proper calfa
8849       side_calf(j)=c(j,k+nres)-c(j,k)
8850 C      side_calf(j)=2.0d0
8851       pept_group(j)=c(j,i)-c(j,i+1)
8852 C lets have their lenght
8853       dist_pep_side=pep_side(j)**2+dist_pep_side
8854       dist_side_calf=dist_side_calf+side_calf(j)**2
8855       dist_pept_group=dist_pept_group+pept_group(j)**2
8856       enddo
8857        dist_pep_side=dsqrt(dist_pep_side)
8858        dist_pept_group=dsqrt(dist_pept_group)
8859        dist_side_calf=dsqrt(dist_side_calf)
8860       do j=1,3
8861         pep_side_norm(j)=pep_side(j)/dist_pep_side
8862         side_calf_norm(j)=dist_side_calf
8863       enddo
8864 C now sscale fraction
8865        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8866 C       print *,buff_shield,"buff"
8867 C now sscale
8868         if (sh_frac_dist.le.0.0) cycle
8869 C If we reach here it means that this side chain reaches the shielding sphere
8870 C Lets add him to the list for gradient
8871         ishield_list(i)=ishield_list(i)+1
8872 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8873 C this list is essential otherwise problem would be O3
8874         shield_list(ishield_list(i),i)=k
8875 C Lets have the sscale value
8876         if (sh_frac_dist.gt.1.0) then
8877          scale_fac_dist=1.0d0
8878          do j=1,3
8879          sh_frac_dist_grad(j)=0.0d0
8880          enddo
8881         else
8882          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8883      &                   *(2.0d0*sh_frac_dist-3.0d0)
8884          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8885      &                  /dist_pep_side/buff_shield*0.5d0
8886 C remember for the final gradient multiply sh_frac_dist_grad(j)
8887 C for side_chain by factor -2 !
8888          do j=1,3
8889          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8890 C         sh_frac_dist_grad(j)=0.0d0
8891 C         scale_fac_dist=1.0d0
8892 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8893 C     &                    sh_frac_dist_grad(j)
8894          enddo
8895         endif
8896 C this is what is now we have the distance scaling now volume...
8897       short=short_r_sidechain(itype(k))
8898       long=long_r_sidechain(itype(k))
8899       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8900       sinthet=short/dist_pep_side*costhet
8901 C now costhet_grad
8902 C       costhet=0.6d0
8903 C       sinthet=0.8
8904        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8905 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8906 C     &             -short/dist_pep_side**2/costhet)
8907 C       costhet_fac=0.0d0
8908        do j=1,3
8909          costhet_grad(j)=costhet_fac*pep_side(j)
8910        enddo
8911 C remember for the final gradient multiply costhet_grad(j)
8912 C for side_chain by factor -2 !
8913 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8914 C pep_side0pept_group is vector multiplication
8915       pep_side0pept_group=0.0d0
8916       do j=1,3
8917       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8918       enddo
8919       cosalfa=(pep_side0pept_group/
8920      & (dist_pep_side*dist_side_calf))
8921       fac_alfa_sin=1.0d0-cosalfa**2
8922       fac_alfa_sin=dsqrt(fac_alfa_sin)
8923       rkprim=fac_alfa_sin*(long-short)+short
8924 C      rkprim=short
8925
8926 C now costhet_grad
8927        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8928 C       cosphi=0.6
8929        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8930        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8931      &      dist_pep_side**2)
8932 C       sinphi=0.8
8933        do j=1,3
8934          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8935      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8936      &*(long-short)/fac_alfa_sin*cosalfa/
8937      &((dist_pep_side*dist_side_calf))*
8938      &((side_calf(j))-cosalfa*
8939      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8940 C       cosphi_grad_long(j)=0.0d0
8941         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8942      &*(long-short)/fac_alfa_sin*cosalfa
8943      &/((dist_pep_side*dist_side_calf))*
8944      &(pep_side(j)-
8945      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8946 C       cosphi_grad_loc(j)=0.0d0
8947        enddo
8948 C      print *,sinphi,sinthet
8949       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
8950      &                    /VSolvSphere_div
8951 C     &                    *wshield
8952 C now the gradient...
8953       do j=1,3
8954       grad_shield(j,i)=grad_shield(j,i)
8955 C gradient po skalowaniu
8956      &                +(sh_frac_dist_grad(j)*VofOverlap
8957 C  gradient po costhet
8958      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
8959      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8960      &       sinphi/sinthet*costhet*costhet_grad(j)
8961      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8962      & )*wshield
8963 C grad_shield_side is Cbeta sidechain gradient
8964       grad_shield_side(j,ishield_list(i),i)=
8965      &        (sh_frac_dist_grad(j)*-2.0d0
8966      &        *VofOverlap
8967      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8968      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8969      &       sinphi/sinthet*costhet*costhet_grad(j)
8970      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8971      &       )*wshield
8972
8973        grad_shield_loc(j,ishield_list(i),i)=
8974      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8975      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
8976      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
8977      &        ))
8978      &        *wshield
8979       enddo
8980       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8981       enddo
8982       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
8983 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8984 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
8985       enddo
8986       return
8987       end
8988