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 179
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   179 continue
3173       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3174       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3175 C changes suggested by Ana to avoid out of bounds
3176 C     & .or.((i+5).gt.nres)
3177 C     & .or.((i-1).le.0)
3178 C end of changes suggested by Ana
3179      &    .or. itype(i+3).eq.ntyp1
3180      &    .or. itype(i+4).eq.ntyp1
3181 C     &    .or. itype(i+5).eq.ntyp1
3182      &    .or. itype(i).eq.ntyp1
3183 C     &    .or. itype(i-1).eq.ntyp1
3184      &    ) goto 178
3185 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3186 C
3187 C               Fourth-order contributions
3188 C
3189 C                 (i+3)o----(i+4)
3190 C                     /  |
3191 C               (i+2)o   |
3192 C                     \  |
3193 C                 (i+1)o----i
3194 C
3195 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3196 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3197         iti1=itortyp(itype(i+1))
3198         iti2=itortyp(itype(i+2))
3199         iti3=itortyp(itype(i+3))
3200         call transpose2(EUg(1,1,i+1),e1t(1,1))
3201         call transpose2(Eug(1,1,i+2),e2t(1,1))
3202         call transpose2(Eug(1,1,i+3),e3t(1,1))
3203         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3204         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3205         s1=scalar2(b1(1,iti2),auxvec(1))
3206         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3207         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3208         s2=scalar2(b1(1,iti1),auxvec(1))
3209         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3210         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3211         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3212         if (shield_mode.eq.0) then
3213         fac_shield(i)=1.0
3214         fac_shield(j)=1.0
3215 C        else
3216 C        fac_shield(i)=0.4
3217 C        fac_shield(j)=0.6
3218         endif
3219
3220         eello_turn4=eello_turn4-(s1+s2+s3)
3221      &  *fac_shield(i)*fac_shield(j)
3222         eello_t4=-(s1+s2+s3)
3223      &  *fac_shield(i)*fac_shield(j)
3224
3225 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3226 cd     &    ' eello_turn4_num',8*eello_turn4_num
3227 C Derivatives in gamma(i)
3228         if (calc_grad) then
3229           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3230      &  (shield_mode.gt.0)) then
3231 C          print *,i,j
3232
3233           do ilist=1,ishield_list(i)
3234            iresshield=shield_list(ilist,i)
3235            do k=1,3
3236            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3237 C     &      *2.0
3238            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3239      &              rlocshield
3240      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3241             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3242      &      +rlocshield
3243            enddo
3244           enddo
3245           do ilist=1,ishield_list(j)
3246            iresshield=shield_list(ilist,j)
3247            do k=1,3
3248            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3249 C     &     *2.0
3250            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3251      &              rlocshield
3252      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3253            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3254      &             +rlocshield
3255
3256            enddo
3257           enddo
3258
3259           do k=1,3
3260             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3261      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3262             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3263      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3264             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3265      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3266             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3267      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3268            enddo
3269            endif
3270         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3271         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3272         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3273         s1=scalar2(b1(1,iti2),auxvec(1))
3274         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3275         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3276         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3277      &  *fac_shield(i)*fac_shield(j)
3278
3279 C Derivatives in gamma(i+1)
3280         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3281         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3282         s2=scalar2(b1(1,iti1),auxvec(1))
3283         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3284         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3285         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3286         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3287      &  *fac_shield(i)*fac_shield(j)
3288
3289 C Derivatives in gamma(i+2)
3290         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3291         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3292         s1=scalar2(b1(1,iti2),auxvec(1))
3293         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3294         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3295         s2=scalar2(b1(1,iti1),auxvec(1))
3296         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3297         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3298         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3299         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3300      &  *fac_shield(i)*fac_shield(j)
3301
3302 C Cartesian derivatives
3303
3304 C Derivatives of this turn contributions in DC(i+2)
3305         if (j.lt.nres-1) then
3306           do l=1,3
3307             a_temp(1,1)=agg(l,1)
3308             a_temp(1,2)=agg(l,2)
3309             a_temp(2,1)=agg(l,3)
3310             a_temp(2,2)=agg(l,4)
3311             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3312             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3313             s1=scalar2(b1(1,iti2),auxvec(1))
3314             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3315             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3316             s2=scalar2(b1(1,iti1),auxvec(1))
3317             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3318             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3319             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3320             ggg(l)=-(s1+s2+s3)
3321             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3322      &  *fac_shield(i)*fac_shield(j)
3323
3324           enddo
3325         endif
3326 C Remaining derivatives of this turn contribution
3327         do l=1,3
3328           a_temp(1,1)=aggi(l,1)
3329           a_temp(1,2)=aggi(l,2)
3330           a_temp(2,1)=aggi(l,3)
3331           a_temp(2,2)=aggi(l,4)
3332           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3333           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3334           s1=scalar2(b1(1,iti2),auxvec(1))
3335           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3336           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3337           s2=scalar2(b1(1,iti1),auxvec(1))
3338           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3339           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3340           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3341           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3342      &  *fac_shield(i)*fac_shield(j)
3343
3344           a_temp(1,1)=aggi1(l,1)
3345           a_temp(1,2)=aggi1(l,2)
3346           a_temp(2,1)=aggi1(l,3)
3347           a_temp(2,2)=aggi1(l,4)
3348           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3349           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3350           s1=scalar2(b1(1,iti2),auxvec(1))
3351           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3352           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3353           s2=scalar2(b1(1,iti1),auxvec(1))
3354           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3355           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3356           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3357           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3358      &  *fac_shield(i)*fac_shield(j)
3359
3360           a_temp(1,1)=aggj(l,1)
3361           a_temp(1,2)=aggj(l,2)
3362           a_temp(2,1)=aggj(l,3)
3363           a_temp(2,2)=aggj(l,4)
3364           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3365           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3366           s1=scalar2(b1(1,iti2),auxvec(1))
3367           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3368           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3369           s2=scalar2(b1(1,iti1),auxvec(1))
3370           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3371           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3372           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3373           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3374      &  *fac_shield(i)*fac_shield(j)
3375
3376           a_temp(1,1)=aggj1(l,1)
3377           a_temp(1,2)=aggj1(l,2)
3378           a_temp(2,1)=aggj1(l,3)
3379           a_temp(2,2)=aggj1(l,4)
3380           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3381           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3382           s1=scalar2(b1(1,iti2),auxvec(1))
3383           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3384           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3385           s2=scalar2(b1(1,iti1),auxvec(1))
3386           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3387           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3388           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3389           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3390      &  *fac_shield(i)*fac_shield(j)
3391
3392         enddo
3393         endif
3394  178  continue
3395       endif
3396       return
3397       end
3398 C-----------------------------------------------------------------------------
3399       subroutine vecpr(u,v,w)
3400       implicit real*8(a-h,o-z)
3401       dimension u(3),v(3),w(3)
3402       w(1)=u(2)*v(3)-u(3)*v(2)
3403       w(2)=-u(1)*v(3)+u(3)*v(1)
3404       w(3)=u(1)*v(2)-u(2)*v(1)
3405       return
3406       end
3407 C-----------------------------------------------------------------------------
3408       subroutine unormderiv(u,ugrad,unorm,ungrad)
3409 C This subroutine computes the derivatives of a normalized vector u, given
3410 C the derivatives computed without normalization conditions, ugrad. Returns
3411 C ungrad.
3412       implicit none
3413       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3414       double precision vec(3)
3415       double precision scalar
3416       integer i,j
3417 c      write (2,*) 'ugrad',ugrad
3418 c      write (2,*) 'u',u
3419       do i=1,3
3420         vec(i)=scalar(ugrad(1,i),u(1))
3421       enddo
3422 c      write (2,*) 'vec',vec
3423       do i=1,3
3424         do j=1,3
3425           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3426         enddo
3427       enddo
3428 c      write (2,*) 'ungrad',ungrad
3429       return
3430       end
3431 C-----------------------------------------------------------------------------
3432       subroutine escp(evdw2,evdw2_14)
3433 C
3434 C This subroutine calculates the excluded-volume interaction energy between
3435 C peptide-group centers and side chains and its gradient in virtual-bond and
3436 C side-chain vectors.
3437 C
3438       implicit real*8 (a-h,o-z)
3439       include 'DIMENSIONS'
3440       include 'DIMENSIONS.ZSCOPT'
3441       include 'COMMON.GEO'
3442       include 'COMMON.VAR'
3443       include 'COMMON.LOCAL'
3444       include 'COMMON.CHAIN'
3445       include 'COMMON.DERIV'
3446       include 'COMMON.INTERACT'
3447       include 'COMMON.FFIELD'
3448       include 'COMMON.IOUNITS'
3449       dimension ggg(3)
3450       evdw2=0.0D0
3451       evdw2_14=0.0d0
3452 cd    print '(a)','Enter ESCP'
3453 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3454 c     &  ' scal14',scal14
3455       do i=iatscp_s,iatscp_e
3456         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3457         iteli=itel(i)
3458 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3459 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3460         if (iteli.eq.0) goto 1225
3461         xi=0.5D0*(c(1,i)+c(1,i+1))
3462         yi=0.5D0*(c(2,i)+c(2,i+1))
3463         zi=0.5D0*(c(3,i)+c(3,i+1))
3464 C Returning the ith atom to box
3465           xi=mod(xi,boxxsize)
3466           if (xi.lt.0) xi=xi+boxxsize
3467           yi=mod(yi,boxysize)
3468           if (yi.lt.0) yi=yi+boxysize
3469           zi=mod(zi,boxzsize)
3470           if (zi.lt.0) zi=zi+boxzsize
3471         do iint=1,nscp_gr(i)
3472
3473         do j=iscpstart(i,iint),iscpend(i,iint)
3474           itypj=iabs(itype(j))
3475           if (itypj.eq.ntyp1) cycle
3476 C Uncomment following three lines for SC-p interactions
3477 c         xj=c(1,nres+j)-xi
3478 c         yj=c(2,nres+j)-yi
3479 c         zj=c(3,nres+j)-zi
3480 C Uncomment following three lines for Ca-p interactions
3481           xj=c(1,j)
3482           yj=c(2,j)
3483           zj=c(3,j)
3484 C returning the jth atom to box
3485           xj=mod(xj,boxxsize)
3486           if (xj.lt.0) xj=xj+boxxsize
3487           yj=mod(yj,boxysize)
3488           if (yj.lt.0) yj=yj+boxysize
3489           zj=mod(zj,boxzsize)
3490           if (zj.lt.0) zj=zj+boxzsize
3491       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3492       xj_safe=xj
3493       yj_safe=yj
3494       zj_safe=zj
3495       subchap=0
3496 C Finding the closest jth atom
3497       do xshift=-1,1
3498       do yshift=-1,1
3499       do zshift=-1,1
3500           xj=xj_safe+xshift*boxxsize
3501           yj=yj_safe+yshift*boxysize
3502           zj=zj_safe+zshift*boxzsize
3503           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3504           if(dist_temp.lt.dist_init) then
3505             dist_init=dist_temp
3506             xj_temp=xj
3507             yj_temp=yj
3508             zj_temp=zj
3509             subchap=1
3510           endif
3511        enddo
3512        enddo
3513        enddo
3514        if (subchap.eq.1) then
3515           xj=xj_temp-xi
3516           yj=yj_temp-yi
3517           zj=zj_temp-zi
3518        else
3519           xj=xj_safe-xi
3520           yj=yj_safe-yi
3521           zj=zj_safe-zi
3522        endif
3523           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3524 C sss is scaling function for smoothing the cutoff gradient otherwise
3525 C the gradient would not be continuouse
3526           sss=sscale(1.0d0/(dsqrt(rrij)))
3527           if (sss.le.0.0d0) cycle
3528           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3529           fac=rrij**expon2
3530           e1=fac*fac*aad(itypj,iteli)
3531           e2=fac*bad(itypj,iteli)
3532           if (iabs(j-i) .le. 2) then
3533             e1=scal14*e1
3534             e2=scal14*e2
3535             evdw2_14=evdw2_14+(e1+e2)*sss
3536           endif
3537           evdwij=e1+e2
3538 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3539 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3540 c     &       bad(itypj,iteli)
3541           evdw2=evdw2+evdwij*sss
3542           if (calc_grad) then
3543 C
3544 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3545 C
3546           fac=-(evdwij+e1)*rrij*sss
3547           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3548           ggg(1)=xj*fac
3549           ggg(2)=yj*fac
3550           ggg(3)=zj*fac
3551           if (j.lt.i) then
3552 cd          write (iout,*) 'j<i'
3553 C Uncomment following three lines for SC-p interactions
3554 c           do k=1,3
3555 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3556 c           enddo
3557           else
3558 cd          write (iout,*) 'j>i'
3559             do k=1,3
3560               ggg(k)=-ggg(k)
3561 C Uncomment following line for SC-p interactions
3562 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3563             enddo
3564           endif
3565           do k=1,3
3566             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3567           enddo
3568           kstart=min0(i+1,j)
3569           kend=max0(i-1,j-1)
3570 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3571 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3572           do k=kstart,kend
3573             do l=1,3
3574               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3575             enddo
3576           enddo
3577           endif
3578         enddo
3579         enddo ! iint
3580  1225   continue
3581       enddo ! i
3582       do i=1,nct
3583         do j=1,3
3584           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3585           gradx_scp(j,i)=expon*gradx_scp(j,i)
3586         enddo
3587       enddo
3588 C******************************************************************************
3589 C
3590 C                              N O T E !!!
3591 C
3592 C To save time the factor EXPON has been extracted from ALL components
3593 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3594 C use!
3595 C
3596 C******************************************************************************
3597       return
3598       end
3599 C--------------------------------------------------------------------------
3600       subroutine edis(ehpb)
3601 C
3602 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3603 C
3604       implicit real*8 (a-h,o-z)
3605       include 'DIMENSIONS'
3606       include 'DIMENSIONS.ZSCOPT'
3607       include 'COMMON.SBRIDGE'
3608       include 'COMMON.CHAIN'
3609       include 'COMMON.DERIV'
3610       include 'COMMON.VAR'
3611       include 'COMMON.INTERACT'
3612       include 'COMMON.CONTROL'
3613       include 'COMMON.IOUNITS'
3614       dimension ggg(3)
3615       ehpb=0.0D0
3616 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3617 cd    print *,'link_start=',link_start,' link_end=',link_end
3618 C      write(iout,*) link_end, "link_end"
3619       if (link_end.eq.0) return
3620       do i=link_start,link_end
3621 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3622 C CA-CA distance used in regularization of structure.
3623         ii=ihpb(i)
3624         jj=jhpb(i)
3625 C iii and jjj point to the residues for which the distance is assigned.
3626         if (ii.gt.nres) then
3627           iii=ii-nres
3628           jjj=jj-nres
3629         else
3630           iii=ii
3631           jjj=jj
3632         endif
3633 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3634 C    distance and angle dependent SS bond potential.
3635 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3636 C     & iabs(itype(jjj)).eq.1) then
3637 C       write(iout,*) constr_dist,"const"
3638        if (.not.dyn_ss .and. i.le.nss) then
3639          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3640      & iabs(itype(jjj)).eq.1) then
3641           call ssbond_ene(iii,jjj,eij)
3642           ehpb=ehpb+2*eij
3643            endif !ii.gt.neres
3644         else if (ii.gt.nres .and. jj.gt.nres) then
3645 c Restraints from contact prediction
3646           dd=dist(ii,jj)
3647           if (constr_dist.eq.11) then
3648 C            ehpb=ehpb+fordepth(i)**4.0d0
3649 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3650             ehpb=ehpb+fordepth(i)**4.0d0
3651      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3652             fac=fordepth(i)**4.0d0
3653      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3654 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3655 C     &    ehpb,fordepth(i),dd
3656 C            write(iout,*) ehpb,"atu?"
3657 C            ehpb,"tu?"
3658 C            fac=fordepth(i)**4.0d0
3659 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3660            else
3661           if (dhpb1(i).gt.0.0d0) then
3662             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3663             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3664 c            write (iout,*) "beta nmr",
3665 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3666           else
3667             dd=dist(ii,jj)
3668             rdis=dd-dhpb(i)
3669 C Get the force constant corresponding to this distance.
3670             waga=forcon(i)
3671 C Calculate the contribution to energy.
3672             ehpb=ehpb+waga*rdis*rdis
3673 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3674 C
3675 C Evaluate gradient.
3676 C
3677             fac=waga*rdis/dd
3678           endif !end dhpb1(i).gt.0
3679           endif !end const_dist=11
3680           do j=1,3
3681             ggg(j)=fac*(c(j,jj)-c(j,ii))
3682           enddo
3683           do j=1,3
3684             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3685             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3686           enddo
3687           do k=1,3
3688             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3689             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3690           enddo
3691         else !ii.gt.nres
3692 C          write(iout,*) "before"
3693           dd=dist(ii,jj)
3694 C          write(iout,*) "after",dd
3695           if (constr_dist.eq.11) then
3696             ehpb=ehpb+fordepth(i)**4.0d0
3697      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3698             fac=fordepth(i)**4.0d0
3699      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3700 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3701 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3702 C            print *,ehpb,"tu?"
3703 C            write(iout,*) ehpb,"btu?",
3704 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3705 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3706 C     &    ehpb,fordepth(i),dd
3707            else
3708           if (dhpb1(i).gt.0.0d0) then
3709             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3710             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3711 c            write (iout,*) "alph nmr",
3712 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3713           else
3714             rdis=dd-dhpb(i)
3715 C Get the force constant corresponding to this distance.
3716             waga=forcon(i)
3717 C Calculate the contribution to energy.
3718             ehpb=ehpb+waga*rdis*rdis
3719 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3720 C
3721 C Evaluate gradient.
3722 C
3723             fac=waga*rdis/dd
3724           endif
3725           endif
3726
3727         do j=1,3
3728           ggg(j)=fac*(c(j,jj)-c(j,ii))
3729         enddo
3730 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3731 C If this is a SC-SC distance, we need to calculate the contributions to the
3732 C Cartesian gradient in the SC vectors (ghpbx).
3733         if (iii.lt.ii) then
3734           do j=1,3
3735             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3736             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3737           enddo
3738         endif
3739         do j=iii,jjj-1
3740           do k=1,3
3741             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3742           enddo
3743         enddo
3744         endif
3745       enddo
3746       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3747       return
3748       end
3749 C--------------------------------------------------------------------------
3750       subroutine ssbond_ene(i,j,eij)
3751 C
3752 C Calculate the distance and angle dependent SS-bond potential energy
3753 C using a free-energy function derived based on RHF/6-31G** ab initio
3754 C calculations of diethyl disulfide.
3755 C
3756 C A. Liwo and U. Kozlowska, 11/24/03
3757 C
3758       implicit real*8 (a-h,o-z)
3759       include 'DIMENSIONS'
3760       include 'DIMENSIONS.ZSCOPT'
3761       include 'COMMON.SBRIDGE'
3762       include 'COMMON.CHAIN'
3763       include 'COMMON.DERIV'
3764       include 'COMMON.LOCAL'
3765       include 'COMMON.INTERACT'
3766       include 'COMMON.VAR'
3767       include 'COMMON.IOUNITS'
3768       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3769       itypi=iabs(itype(i))
3770       xi=c(1,nres+i)
3771       yi=c(2,nres+i)
3772       zi=c(3,nres+i)
3773       dxi=dc_norm(1,nres+i)
3774       dyi=dc_norm(2,nres+i)
3775       dzi=dc_norm(3,nres+i)
3776       dsci_inv=dsc_inv(itypi)
3777       itypj=iabs(itype(j))
3778       dscj_inv=dsc_inv(itypj)
3779       xj=c(1,nres+j)-xi
3780       yj=c(2,nres+j)-yi
3781       zj=c(3,nres+j)-zi
3782       dxj=dc_norm(1,nres+j)
3783       dyj=dc_norm(2,nres+j)
3784       dzj=dc_norm(3,nres+j)
3785       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3786       rij=dsqrt(rrij)
3787       erij(1)=xj*rij
3788       erij(2)=yj*rij
3789       erij(3)=zj*rij
3790       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3791       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3792       om12=dxi*dxj+dyi*dyj+dzi*dzj
3793       do k=1,3
3794         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3795         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3796       enddo
3797       rij=1.0d0/rij
3798       deltad=rij-d0cm
3799       deltat1=1.0d0-om1
3800       deltat2=1.0d0+om2
3801       deltat12=om2-om1+2.0d0
3802       cosphi=om12-om1*om2
3803       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3804      &  +akct*deltad*deltat12
3805      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3806 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3807 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3808 c     &  " deltat12",deltat12," eij",eij
3809       ed=2*akcm*deltad+akct*deltat12
3810       pom1=akct*deltad
3811       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3812       eom1=-2*akth*deltat1-pom1-om2*pom2
3813       eom2= 2*akth*deltat2+pom1-om1*pom2
3814       eom12=pom2
3815       do k=1,3
3816         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3817       enddo
3818       do k=1,3
3819         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3820      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3821         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3822      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3823       enddo
3824 C
3825 C Calculate the components of the gradient in DC and X
3826 C
3827       do k=i,j-1
3828         do l=1,3
3829           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3830         enddo
3831       enddo
3832       return
3833       end
3834 C--------------------------------------------------------------------------
3835       subroutine ebond(estr)
3836 c
3837 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3838 c
3839       implicit real*8 (a-h,o-z)
3840       include 'DIMENSIONS'
3841       include 'DIMENSIONS.ZSCOPT'
3842       include 'COMMON.LOCAL'
3843       include 'COMMON.GEO'
3844       include 'COMMON.INTERACT'
3845       include 'COMMON.DERIV'
3846       include 'COMMON.VAR'
3847       include 'COMMON.CHAIN'
3848       include 'COMMON.IOUNITS'
3849       include 'COMMON.NAMES'
3850       include 'COMMON.FFIELD'
3851       include 'COMMON.CONTROL'
3852       logical energy_dec /.false./
3853       double precision u(3),ud(3)
3854       estr=0.0d0
3855       estr1=0.0d0
3856 c      write (iout,*) "distchainmax",distchainmax
3857       do i=nnt+1,nct
3858         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3859 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3860 C          do j=1,3
3861 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3862 C     &      *dc(j,i-1)/vbld(i)
3863 C          enddo
3864 C          if (energy_dec) write(iout,*)
3865 C     &       "estr1",i,vbld(i),distchainmax,
3866 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3867 C        else
3868          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3869         diff = vbld(i)-vbldpDUM
3870 C         write(iout,*) i,diff
3871          else
3872           diff = vbld(i)-vbldp0
3873 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3874          endif
3875           estr=estr+diff*diff
3876           do j=1,3
3877             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3878           enddo
3879 C        endif
3880 C        write (iout,'(a7,i5,4f7.3)')
3881 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3882       enddo
3883       estr=0.5d0*AKP*estr+estr1
3884 c
3885 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3886 c
3887       do i=nnt,nct
3888         iti=iabs(itype(i))
3889         if (iti.ne.10 .and. iti.ne.ntyp1) then
3890           nbi=nbondterm(iti)
3891           if (nbi.eq.1) then
3892             diff=vbld(i+nres)-vbldsc0(1,iti)
3893 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3894 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3895             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3896             do j=1,3
3897               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3898             enddo
3899           else
3900             do j=1,nbi
3901               diff=vbld(i+nres)-vbldsc0(j,iti)
3902               ud(j)=aksc(j,iti)*diff
3903               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3904             enddo
3905             uprod=u(1)
3906             do j=2,nbi
3907               uprod=uprod*u(j)
3908             enddo
3909             usum=0.0d0
3910             usumsqder=0.0d0
3911             do j=1,nbi
3912               uprod1=1.0d0
3913               uprod2=1.0d0
3914               do k=1,nbi
3915                 if (k.ne.j) then
3916                   uprod1=uprod1*u(k)
3917                   uprod2=uprod2*u(k)*u(k)
3918                 endif
3919               enddo
3920               usum=usum+uprod1
3921               usumsqder=usumsqder+ud(j)*uprod2
3922             enddo
3923 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3924 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3925             estr=estr+uprod/usum
3926             do j=1,3
3927              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3928             enddo
3929           endif
3930         endif
3931       enddo
3932       return
3933       end
3934 #ifdef CRYST_THETA
3935 C--------------------------------------------------------------------------
3936       subroutine ebend(etheta,ethetacnstr)
3937 C
3938 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3939 C angles gamma and its derivatives in consecutive thetas and gammas.
3940 C
3941       implicit real*8 (a-h,o-z)
3942       include 'DIMENSIONS'
3943       include 'DIMENSIONS.ZSCOPT'
3944       include 'COMMON.LOCAL'
3945       include 'COMMON.GEO'
3946       include 'COMMON.INTERACT'
3947       include 'COMMON.DERIV'
3948       include 'COMMON.VAR'
3949       include 'COMMON.CHAIN'
3950       include 'COMMON.IOUNITS'
3951       include 'COMMON.NAMES'
3952       include 'COMMON.FFIELD'
3953       include 'COMMON.TORCNSTR'
3954       common /calcthet/ term1,term2,termm,diffak,ratak,
3955      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3956      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3957       double precision y(2),z(2)
3958       delta=0.02d0*pi
3959 c      time11=dexp(-2*time)
3960 c      time12=1.0d0
3961       etheta=0.0D0
3962 c      write (iout,*) "nres",nres
3963 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3964 c      write (iout,*) ithet_start,ithet_end
3965       do i=ithet_start,ithet_end
3966 C        if (itype(i-1).eq.ntyp1) cycle
3967         if (i.le.2) cycle
3968         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
3969      &  .or.itype(i).eq.ntyp1) cycle
3970 C Zero the energy function and its derivative at 0 or pi.
3971         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3972         it=itype(i-1)
3973         ichir1=isign(1,itype(i-2))
3974         ichir2=isign(1,itype(i))
3975          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
3976          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
3977          if (itype(i-1).eq.10) then
3978           itype1=isign(10,itype(i-2))
3979           ichir11=isign(1,itype(i-2))
3980           ichir12=isign(1,itype(i-2))
3981           itype2=isign(10,itype(i))
3982           ichir21=isign(1,itype(i))
3983           ichir22=isign(1,itype(i))
3984          endif
3985          if (i.eq.3) then
3986           y(1)=0.0D0
3987           y(2)=0.0D0
3988           else
3989
3990         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3991 #ifdef OSF
3992           phii=phi(i)
3993 c          icrc=0
3994 c          call proc_proc(phii,icrc)
3995           if (icrc.eq.1) phii=150.0
3996 #else
3997           phii=phi(i)
3998 #endif
3999           y(1)=dcos(phii)
4000           y(2)=dsin(phii)
4001         else
4002           y(1)=0.0D0
4003           y(2)=0.0D0
4004         endif
4005         endif
4006         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4007 #ifdef OSF
4008           phii1=phi(i+1)
4009 c          icrc=0
4010 c          call proc_proc(phii1,icrc)
4011           if (icrc.eq.1) phii1=150.0
4012           phii1=pinorm(phii1)
4013           z(1)=cos(phii1)
4014 #else
4015           phii1=phi(i+1)
4016           z(1)=dcos(phii1)
4017 #endif
4018           z(2)=dsin(phii1)
4019         else
4020           z(1)=0.0D0
4021           z(2)=0.0D0
4022         endif
4023 C Calculate the "mean" value of theta from the part of the distribution
4024 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4025 C In following comments this theta will be referred to as t_c.
4026         thet_pred_mean=0.0d0
4027         do k=1,2
4028             athetk=athet(k,it,ichir1,ichir2)
4029             bthetk=bthet(k,it,ichir1,ichir2)
4030           if (it.eq.10) then
4031              athetk=athet(k,itype1,ichir11,ichir12)
4032              bthetk=bthet(k,itype2,ichir21,ichir22)
4033           endif
4034           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4035         enddo
4036 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4037         dthett=thet_pred_mean*ssd
4038         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4039 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4040 C Derivatives of the "mean" values in gamma1 and gamma2.
4041         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4042      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4043          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4044      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4045          if (it.eq.10) then
4046       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4047      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4048         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4049      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4050          endif
4051         if (theta(i).gt.pi-delta) then
4052           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4053      &         E_tc0)
4054           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4055           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4056           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4057      &        E_theta)
4058           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4059      &        E_tc)
4060         else if (theta(i).lt.delta) then
4061           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4062           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4063           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4064      &        E_theta)
4065           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4066           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4067      &        E_tc)
4068         else
4069           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4070      &        E_theta,E_tc)
4071         endif
4072         etheta=etheta+ethetai
4073 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4074 c     &      'ebend',i,ethetai,theta(i),itype(i)
4075 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4076 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4077         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4078         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4079         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4080 c 1215   continue
4081       enddo
4082       ethetacnstr=0.0d0
4083 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4084       do i=1,ntheta_constr
4085         itheta=itheta_constr(i)
4086         thetiii=theta(itheta)
4087         difi=pinorm(thetiii-theta_constr0(i))
4088         if (difi.gt.theta_drange(i)) then
4089           difi=difi-theta_drange(i)
4090           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4091           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4092      &    +for_thet_constr(i)*difi**3
4093         else if (difi.lt.-drange(i)) then
4094           difi=difi+drange(i)
4095           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4096           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4097      &    +for_thet_constr(i)*difi**3
4098         else
4099           difi=0.0
4100         endif
4101 C       if (energy_dec) then
4102 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4103 C     &    i,itheta,rad2deg*thetiii,
4104 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4105 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4106 C     &    gloc(itheta+nphi-2,icg)
4107 C        endif
4108       enddo
4109 C Ufff.... We've done all this!!!
4110       return
4111       end
4112 C---------------------------------------------------------------------------
4113       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4114      &     E_tc)
4115       implicit real*8 (a-h,o-z)
4116       include 'DIMENSIONS'
4117       include 'COMMON.LOCAL'
4118       include 'COMMON.IOUNITS'
4119       common /calcthet/ term1,term2,termm,diffak,ratak,
4120      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4121      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4122 C Calculate the contributions to both Gaussian lobes.
4123 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4124 C The "polynomial part" of the "standard deviation" of this part of
4125 C the distribution.
4126         sig=polthet(3,it)
4127         do j=2,0,-1
4128           sig=sig*thet_pred_mean+polthet(j,it)
4129         enddo
4130 C Derivative of the "interior part" of the "standard deviation of the"
4131 C gamma-dependent Gaussian lobe in t_c.
4132         sigtc=3*polthet(3,it)
4133         do j=2,1,-1
4134           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4135         enddo
4136         sigtc=sig*sigtc
4137 C Set the parameters of both Gaussian lobes of the distribution.
4138 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4139         fac=sig*sig+sigc0(it)
4140         sigcsq=fac+fac
4141         sigc=1.0D0/sigcsq
4142 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4143         sigsqtc=-4.0D0*sigcsq*sigtc
4144 c       print *,i,sig,sigtc,sigsqtc
4145 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4146         sigtc=-sigtc/(fac*fac)
4147 C Following variable is sigma(t_c)**(-2)
4148         sigcsq=sigcsq*sigcsq
4149         sig0i=sig0(it)
4150         sig0inv=1.0D0/sig0i**2
4151         delthec=thetai-thet_pred_mean
4152         delthe0=thetai-theta0i
4153         term1=-0.5D0*sigcsq*delthec*delthec
4154         term2=-0.5D0*sig0inv*delthe0*delthe0
4155 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4156 C NaNs in taking the logarithm. We extract the largest exponent which is added
4157 C to the energy (this being the log of the distribution) at the end of energy
4158 C term evaluation for this virtual-bond angle.
4159         if (term1.gt.term2) then
4160           termm=term1
4161           term2=dexp(term2-termm)
4162           term1=1.0d0
4163         else
4164           termm=term2
4165           term1=dexp(term1-termm)
4166           term2=1.0d0
4167         endif
4168 C The ratio between the gamma-independent and gamma-dependent lobes of
4169 C the distribution is a Gaussian function of thet_pred_mean too.
4170         diffak=gthet(2,it)-thet_pred_mean
4171         ratak=diffak/gthet(3,it)**2
4172         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4173 C Let's differentiate it in thet_pred_mean NOW.
4174         aktc=ak*ratak
4175 C Now put together the distribution terms to make complete distribution.
4176         termexp=term1+ak*term2
4177         termpre=sigc+ak*sig0i
4178 C Contribution of the bending energy from this theta is just the -log of
4179 C the sum of the contributions from the two lobes and the pre-exponential
4180 C factor. Simple enough, isn't it?
4181         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4182 C NOW the derivatives!!!
4183 C 6/6/97 Take into account the deformation.
4184         E_theta=(delthec*sigcsq*term1
4185      &       +ak*delthe0*sig0inv*term2)/termexp
4186         E_tc=((sigtc+aktc*sig0i)/termpre
4187      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4188      &       aktc*term2)/termexp)
4189       return
4190       end
4191 c-----------------------------------------------------------------------------
4192       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4193       implicit real*8 (a-h,o-z)
4194       include 'DIMENSIONS'
4195       include 'COMMON.LOCAL'
4196       include 'COMMON.IOUNITS'
4197       common /calcthet/ term1,term2,termm,diffak,ratak,
4198      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4199      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4200       delthec=thetai-thet_pred_mean
4201       delthe0=thetai-theta0i
4202 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4203       t3 = thetai-thet_pred_mean
4204       t6 = t3**2
4205       t9 = term1
4206       t12 = t3*sigcsq
4207       t14 = t12+t6*sigsqtc
4208       t16 = 1.0d0
4209       t21 = thetai-theta0i
4210       t23 = t21**2
4211       t26 = term2
4212       t27 = t21*t26
4213       t32 = termexp
4214       t40 = t32**2
4215       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4216      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4217      & *(-t12*t9-ak*sig0inv*t27)
4218       return
4219       end
4220 #else
4221 C--------------------------------------------------------------------------
4222       subroutine ebend(etheta,ethetacnstr)
4223 C
4224 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4225 C angles gamma and its derivatives in consecutive thetas and gammas.
4226 C ab initio-derived potentials from
4227 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4228 C
4229       implicit real*8 (a-h,o-z)
4230       include 'DIMENSIONS'
4231       include 'DIMENSIONS.ZSCOPT'
4232       include 'COMMON.LOCAL'
4233       include 'COMMON.GEO'
4234       include 'COMMON.INTERACT'
4235       include 'COMMON.DERIV'
4236       include 'COMMON.VAR'
4237       include 'COMMON.CHAIN'
4238       include 'COMMON.IOUNITS'
4239       include 'COMMON.NAMES'
4240       include 'COMMON.FFIELD'
4241       include 'COMMON.CONTROL'
4242       include 'COMMON.TORCNSTR'
4243       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4244      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4245      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4246      & sinph1ph2(maxdouble,maxdouble)
4247       logical lprn /.false./, lprn1 /.false./
4248       etheta=0.0D0
4249 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4250       do i=ithet_start,ithet_end
4251 C         if (i.eq.2) cycle
4252 C        if (itype(i-1).eq.ntyp1) cycle
4253         if (i.le.2) cycle
4254         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4255      &  .or.itype(i).eq.ntyp1) cycle
4256         if (iabs(itype(i+1)).eq.20) iblock=2
4257         if (iabs(itype(i+1)).ne.20) iblock=1
4258         dethetai=0.0d0
4259         dephii=0.0d0
4260         dephii1=0.0d0
4261         theti2=0.5d0*theta(i)
4262         ityp2=ithetyp((itype(i-1)))
4263         do k=1,nntheterm
4264           coskt(k)=dcos(k*theti2)
4265           sinkt(k)=dsin(k*theti2)
4266         enddo
4267         if (i.eq.3) then
4268           phii=0.0d0
4269           ityp1=nthetyp+1
4270           do k=1,nsingle
4271             cosph1(k)=0.0d0
4272             sinph1(k)=0.0d0
4273           enddo
4274         else
4275         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4276 #ifdef OSF
4277           phii=phi(i)
4278           if (phii.ne.phii) phii=150.0
4279 #else
4280           phii=phi(i)
4281 #endif
4282           ityp1=ithetyp((itype(i-2)))
4283           do k=1,nsingle
4284             cosph1(k)=dcos(k*phii)
4285             sinph1(k)=dsin(k*phii)
4286           enddo
4287         else
4288           phii=0.0d0
4289 c          ityp1=nthetyp+1
4290           do k=1,nsingle
4291             ityp1=ithetyp((itype(i-2)))
4292             cosph1(k)=0.0d0
4293             sinph1(k)=0.0d0
4294           enddo
4295         endif
4296         endif
4297         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4298 #ifdef OSF
4299           phii1=phi(i+1)
4300           if (phii1.ne.phii1) phii1=150.0
4301           phii1=pinorm(phii1)
4302 #else
4303           phii1=phi(i+1)
4304 #endif
4305           ityp3=ithetyp((itype(i)))
4306           do k=1,nsingle
4307             cosph2(k)=dcos(k*phii1)
4308             sinph2(k)=dsin(k*phii1)
4309           enddo
4310         else
4311           phii1=0.0d0
4312 c          ityp3=nthetyp+1
4313           ityp3=ithetyp((itype(i)))
4314           do k=1,nsingle
4315             cosph2(k)=0.0d0
4316             sinph2(k)=0.0d0
4317           enddo
4318         endif
4319 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4320 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4321 c        call flush(iout)
4322         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4323         do k=1,ndouble
4324           do l=1,k-1
4325             ccl=cosph1(l)*cosph2(k-l)
4326             ssl=sinph1(l)*sinph2(k-l)
4327             scl=sinph1(l)*cosph2(k-l)
4328             csl=cosph1(l)*sinph2(k-l)
4329             cosph1ph2(l,k)=ccl-ssl
4330             cosph1ph2(k,l)=ccl+ssl
4331             sinph1ph2(l,k)=scl+csl
4332             sinph1ph2(k,l)=scl-csl
4333           enddo
4334         enddo
4335         if (lprn) then
4336         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4337      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4338         write (iout,*) "coskt and sinkt"
4339         do k=1,nntheterm
4340           write (iout,*) k,coskt(k),sinkt(k)
4341         enddo
4342         endif
4343         do k=1,ntheterm
4344           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4345           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4346      &      *coskt(k)
4347           if (lprn)
4348      &    write (iout,*) "k",k,"
4349      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4350      &     " ethetai",ethetai
4351         enddo
4352         if (lprn) then
4353         write (iout,*) "cosph and sinph"
4354         do k=1,nsingle
4355           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4356         enddo
4357         write (iout,*) "cosph1ph2 and sinph2ph2"
4358         do k=2,ndouble
4359           do l=1,k-1
4360             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4361      &         sinph1ph2(l,k),sinph1ph2(k,l)
4362           enddo
4363         enddo
4364         write(iout,*) "ethetai",ethetai
4365         endif
4366         do m=1,ntheterm2
4367           do k=1,nsingle
4368             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4369      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4370      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4371      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4372             ethetai=ethetai+sinkt(m)*aux
4373             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4374             dephii=dephii+k*sinkt(m)*(
4375      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4376      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4377             dephii1=dephii1+k*sinkt(m)*(
4378      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4379      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4380             if (lprn)
4381      &      write (iout,*) "m",m," k",k," bbthet",
4382      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4383      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4384      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4385      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4386           enddo
4387         enddo
4388         if (lprn)
4389      &  write(iout,*) "ethetai",ethetai
4390         do m=1,ntheterm3
4391           do k=2,ndouble
4392             do l=1,k-1
4393               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4394      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4395      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4396      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4397               ethetai=ethetai+sinkt(m)*aux
4398               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4399               dephii=dephii+l*sinkt(m)*(
4400      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4401      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4402      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4403      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4404               dephii1=dephii1+(k-l)*sinkt(m)*(
4405      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4406      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4407      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4408      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4409               if (lprn) then
4410               write (iout,*) "m",m," k",k," l",l," ffthet",
4411      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4412      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4413      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4414      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4415      &            " ethetai",ethetai
4416               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4417      &            cosph1ph2(k,l)*sinkt(m),
4418      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4419               endif
4420             enddo
4421           enddo
4422         enddo
4423 10      continue
4424         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4425      &   i,theta(i)*rad2deg,phii*rad2deg,
4426      &   phii1*rad2deg,ethetai
4427         etheta=etheta+ethetai
4428         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4429         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4430 c        gloc(nphi+i-2,icg)=wang*dethetai
4431         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4432       enddo
4433 C now constrains
4434       ethetacnstr=0.0d0
4435 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4436       do i=1,ntheta_constr
4437         itheta=itheta_constr(i)
4438         thetiii=theta(itheta)
4439         difi=pinorm(thetiii-theta_constr0(i))
4440         if (difi.gt.theta_drange(i)) then
4441           difi=difi-theta_drange(i)
4442           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4443           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4444      &    +for_thet_constr(i)*difi**3
4445         else if (difi.lt.-drange(i)) then
4446           difi=difi+drange(i)
4447           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4448           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4449      &    +for_thet_constr(i)*difi**3
4450         else
4451           difi=0.0
4452         endif
4453 C       if (energy_dec) then
4454 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4455 C     &    i,itheta,rad2deg*thetiii,
4456 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4457 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4458 C     &    gloc(itheta+nphi-2,icg)
4459 C        endif
4460       enddo
4461       return
4462       end
4463 #endif
4464 #ifdef CRYST_SC
4465 c-----------------------------------------------------------------------------
4466       subroutine esc(escloc)
4467 C Calculate the local energy of a side chain and its derivatives in the
4468 C corresponding virtual-bond valence angles THETA and the spherical angles
4469 C ALPHA and OMEGA.
4470       implicit real*8 (a-h,o-z)
4471       include 'DIMENSIONS'
4472       include 'DIMENSIONS.ZSCOPT'
4473       include 'COMMON.GEO'
4474       include 'COMMON.LOCAL'
4475       include 'COMMON.VAR'
4476       include 'COMMON.INTERACT'
4477       include 'COMMON.DERIV'
4478       include 'COMMON.CHAIN'
4479       include 'COMMON.IOUNITS'
4480       include 'COMMON.NAMES'
4481       include 'COMMON.FFIELD'
4482       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4483      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4484       common /sccalc/ time11,time12,time112,theti,it,nlobit
4485       delta=0.02d0*pi
4486       escloc=0.0D0
4487 C      write (iout,*) 'ESC'
4488       do i=loc_start,loc_end
4489         it=itype(i)
4490         if (it.eq.ntyp1) cycle
4491         if (it.eq.10) goto 1
4492         nlobit=nlob(iabs(it))
4493 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4494 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4495         theti=theta(i+1)-pipol
4496         x(1)=dtan(theti)
4497         x(2)=alph(i)
4498         x(3)=omeg(i)
4499 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4500
4501         if (x(2).gt.pi-delta) then
4502           xtemp(1)=x(1)
4503           xtemp(2)=pi-delta
4504           xtemp(3)=x(3)
4505           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4506           xtemp(2)=pi
4507           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4508           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4509      &        escloci,dersc(2))
4510           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4511      &        ddersc0(1),dersc(1))
4512           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4513      &        ddersc0(3),dersc(3))
4514           xtemp(2)=pi-delta
4515           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4516           xtemp(2)=pi
4517           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4518           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4519      &            dersc0(2),esclocbi,dersc02)
4520           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4521      &            dersc12,dersc01)
4522           call splinthet(x(2),0.5d0*delta,ss,ssd)
4523           dersc0(1)=dersc01
4524           dersc0(2)=dersc02
4525           dersc0(3)=0.0d0
4526           do k=1,3
4527             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4528           enddo
4529           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4530           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4531      &             esclocbi,ss,ssd
4532           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4533 c         escloci=esclocbi
4534 c         write (iout,*) escloci
4535         else if (x(2).lt.delta) then
4536           xtemp(1)=x(1)
4537           xtemp(2)=delta
4538           xtemp(3)=x(3)
4539           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4540           xtemp(2)=0.0d0
4541           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4542           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4543      &        escloci,dersc(2))
4544           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4545      &        ddersc0(1),dersc(1))
4546           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4547      &        ddersc0(3),dersc(3))
4548           xtemp(2)=delta
4549           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4550           xtemp(2)=0.0d0
4551           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4552           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4553      &            dersc0(2),esclocbi,dersc02)
4554           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4555      &            dersc12,dersc01)
4556           dersc0(1)=dersc01
4557           dersc0(2)=dersc02
4558           dersc0(3)=0.0d0
4559           call splinthet(x(2),0.5d0*delta,ss,ssd)
4560           do k=1,3
4561             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4562           enddo
4563           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4564 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4565 c     &             esclocbi,ss,ssd
4566           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4567 C         write (iout,*) 'i=',i, escloci
4568         else
4569           call enesc(x,escloci,dersc,ddummy,.false.)
4570         endif
4571
4572         escloc=escloc+escloci
4573 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4574             write (iout,'(a6,i5,0pf7.3)')
4575      &     'escloc',i,escloci
4576
4577         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4578      &   wscloc*dersc(1)
4579         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4580         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4581     1   continue
4582       enddo
4583       return
4584       end
4585 C---------------------------------------------------------------------------
4586       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4587       implicit real*8 (a-h,o-z)
4588       include 'DIMENSIONS'
4589       include 'COMMON.GEO'
4590       include 'COMMON.LOCAL'
4591       include 'COMMON.IOUNITS'
4592       common /sccalc/ time11,time12,time112,theti,it,nlobit
4593       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4594       double precision contr(maxlob,-1:1)
4595       logical mixed
4596 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4597         escloc_i=0.0D0
4598         do j=1,3
4599           dersc(j)=0.0D0
4600           if (mixed) ddersc(j)=0.0d0
4601         enddo
4602         x3=x(3)
4603
4604 C Because of periodicity of the dependence of the SC energy in omega we have
4605 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4606 C To avoid underflows, first compute & store the exponents.
4607
4608         do iii=-1,1
4609
4610           x(3)=x3+iii*dwapi
4611
4612           do j=1,nlobit
4613             do k=1,3
4614               z(k)=x(k)-censc(k,j,it)
4615             enddo
4616             do k=1,3
4617               Axk=0.0D0
4618               do l=1,3
4619                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4620               enddo
4621               Ax(k,j,iii)=Axk
4622             enddo
4623             expfac=0.0D0
4624             do k=1,3
4625               expfac=expfac+Ax(k,j,iii)*z(k)
4626             enddo
4627             contr(j,iii)=expfac
4628           enddo ! j
4629
4630         enddo ! iii
4631
4632         x(3)=x3
4633 C As in the case of ebend, we want to avoid underflows in exponentiation and
4634 C subsequent NaNs and INFs in energy calculation.
4635 C Find the largest exponent
4636         emin=contr(1,-1)
4637         do iii=-1,1
4638           do j=1,nlobit
4639             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4640           enddo
4641         enddo
4642         emin=0.5D0*emin
4643 cd      print *,'it=',it,' emin=',emin
4644
4645 C Compute the contribution to SC energy and derivatives
4646         do iii=-1,1
4647
4648           do j=1,nlobit
4649             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4650 cd          print *,'j=',j,' expfac=',expfac
4651             escloc_i=escloc_i+expfac
4652             do k=1,3
4653               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4654             enddo
4655             if (mixed) then
4656               do k=1,3,2
4657                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4658      &            +gaussc(k,2,j,it))*expfac
4659               enddo
4660             endif
4661           enddo
4662
4663         enddo ! iii
4664
4665         dersc(1)=dersc(1)/cos(theti)**2
4666         ddersc(1)=ddersc(1)/cos(theti)**2
4667         ddersc(3)=ddersc(3)
4668
4669         escloci=-(dlog(escloc_i)-emin)
4670         do j=1,3
4671           dersc(j)=dersc(j)/escloc_i
4672         enddo
4673         if (mixed) then
4674           do j=1,3,2
4675             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4676           enddo
4677         endif
4678       return
4679       end
4680 C------------------------------------------------------------------------------
4681       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4682       implicit real*8 (a-h,o-z)
4683       include 'DIMENSIONS'
4684       include 'COMMON.GEO'
4685       include 'COMMON.LOCAL'
4686       include 'COMMON.IOUNITS'
4687       common /sccalc/ time11,time12,time112,theti,it,nlobit
4688       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4689       double precision contr(maxlob)
4690       logical mixed
4691
4692       escloc_i=0.0D0
4693
4694       do j=1,3
4695         dersc(j)=0.0D0
4696       enddo
4697
4698       do j=1,nlobit
4699         do k=1,2
4700           z(k)=x(k)-censc(k,j,it)
4701         enddo
4702         z(3)=dwapi
4703         do k=1,3
4704           Axk=0.0D0
4705           do l=1,3
4706             Axk=Axk+gaussc(l,k,j,it)*z(l)
4707           enddo
4708           Ax(k,j)=Axk
4709         enddo
4710         expfac=0.0D0
4711         do k=1,3
4712           expfac=expfac+Ax(k,j)*z(k)
4713         enddo
4714         contr(j)=expfac
4715       enddo ! j
4716
4717 C As in the case of ebend, we want to avoid underflows in exponentiation and
4718 C subsequent NaNs and INFs in energy calculation.
4719 C Find the largest exponent
4720       emin=contr(1)
4721       do j=1,nlobit
4722         if (emin.gt.contr(j)) emin=contr(j)
4723       enddo
4724       emin=0.5D0*emin
4725
4726 C Compute the contribution to SC energy and derivatives
4727
4728       dersc12=0.0d0
4729       do j=1,nlobit
4730         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4731         escloc_i=escloc_i+expfac
4732         do k=1,2
4733           dersc(k)=dersc(k)+Ax(k,j)*expfac
4734         enddo
4735         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4736      &            +gaussc(1,2,j,it))*expfac
4737         dersc(3)=0.0d0
4738       enddo
4739
4740       dersc(1)=dersc(1)/cos(theti)**2
4741       dersc12=dersc12/cos(theti)**2
4742       escloci=-(dlog(escloc_i)-emin)
4743       do j=1,2
4744         dersc(j)=dersc(j)/escloc_i
4745       enddo
4746       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4747       return
4748       end
4749 #else
4750 c----------------------------------------------------------------------------------
4751       subroutine esc(escloc)
4752 C Calculate the local energy of a side chain and its derivatives in the
4753 C corresponding virtual-bond valence angles THETA and the spherical angles
4754 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4755 C added by Urszula Kozlowska. 07/11/2007
4756 C
4757       implicit real*8 (a-h,o-z)
4758       include 'DIMENSIONS'
4759       include 'DIMENSIONS.ZSCOPT'
4760       include 'COMMON.GEO'
4761       include 'COMMON.LOCAL'
4762       include 'COMMON.VAR'
4763       include 'COMMON.SCROT'
4764       include 'COMMON.INTERACT'
4765       include 'COMMON.DERIV'
4766       include 'COMMON.CHAIN'
4767       include 'COMMON.IOUNITS'
4768       include 'COMMON.NAMES'
4769       include 'COMMON.FFIELD'
4770       include 'COMMON.CONTROL'
4771       include 'COMMON.VECTORS'
4772       double precision x_prime(3),y_prime(3),z_prime(3)
4773      &    , sumene,dsc_i,dp2_i,x(65),
4774      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4775      &    de_dxx,de_dyy,de_dzz,de_dt
4776       double precision s1_t,s1_6_t,s2_t,s2_6_t
4777       double precision
4778      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4779      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4780      & dt_dCi(3),dt_dCi1(3)
4781       common /sccalc/ time11,time12,time112,theti,it,nlobit
4782       delta=0.02d0*pi
4783       escloc=0.0D0
4784       do i=loc_start,loc_end
4785         if (itype(i).eq.ntyp1) cycle
4786         costtab(i+1) =dcos(theta(i+1))
4787         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4788         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4789         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4790         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4791         cosfac=dsqrt(cosfac2)
4792         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4793         sinfac=dsqrt(sinfac2)
4794         it=iabs(itype(i))
4795         if (it.eq.10) goto 1
4796 c
4797 C  Compute the axes of tghe local cartesian coordinates system; store in
4798 c   x_prime, y_prime and z_prime
4799 c
4800         do j=1,3
4801           x_prime(j) = 0.00
4802           y_prime(j) = 0.00
4803           z_prime(j) = 0.00
4804         enddo
4805 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4806 C     &   dc_norm(3,i+nres)
4807         do j = 1,3
4808           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4809           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4810         enddo
4811         do j = 1,3
4812           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4813         enddo
4814 c       write (2,*) "i",i
4815 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4816 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4817 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4818 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4819 c      & " xy",scalar(x_prime(1),y_prime(1)),
4820 c      & " xz",scalar(x_prime(1),z_prime(1)),
4821 c      & " yy",scalar(y_prime(1),y_prime(1)),
4822 c      & " yz",scalar(y_prime(1),z_prime(1)),
4823 c      & " zz",scalar(z_prime(1),z_prime(1))
4824 c
4825 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4826 C to local coordinate system. Store in xx, yy, zz.
4827 c
4828         xx=0.0d0
4829         yy=0.0d0
4830         zz=0.0d0
4831         do j = 1,3
4832           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4833           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4834           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4835         enddo
4836
4837         xxtab(i)=xx
4838         yytab(i)=yy
4839         zztab(i)=zz
4840 C
4841 C Compute the energy of the ith side cbain
4842 C
4843 c        write (2,*) "xx",xx," yy",yy," zz",zz
4844         it=iabs(itype(i))
4845         do j = 1,65
4846           x(j) = sc_parmin(j,it)
4847         enddo
4848 #ifdef CHECK_COORD
4849 Cc diagnostics - remove later
4850         xx1 = dcos(alph(2))
4851         yy1 = dsin(alph(2))*dcos(omeg(2))
4852         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4853         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4854      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4855      &    xx1,yy1,zz1
4856 C,"  --- ", xx_w,yy_w,zz_w
4857 c end diagnostics
4858 #endif
4859         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4860      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4861      &   + x(10)*yy*zz
4862         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4863      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4864      & + x(20)*yy*zz
4865         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4866      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4867      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4868      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4869      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4870      &  +x(40)*xx*yy*zz
4871         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4872      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4873      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4874      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4875      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4876      &  +x(60)*xx*yy*zz
4877         dsc_i   = 0.743d0+x(61)
4878         dp2_i   = 1.9d0+x(62)
4879         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4880      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4881         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4882      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4883         s1=(1+x(63))/(0.1d0 + dscp1)
4884         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4885         s2=(1+x(65))/(0.1d0 + dscp2)
4886         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4887         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4888      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4889 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4890 c     &   sumene4,
4891 c     &   dscp1,dscp2,sumene
4892 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4893         escloc = escloc + sumene
4894 c        write (2,*) "escloc",escloc
4895 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
4896 c     &  zz,xx,yy
4897         if (.not. calc_grad) goto 1
4898 #ifdef DEBUG
4899 C
4900 C This section to check the numerical derivatives of the energy of ith side
4901 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4902 C #define DEBUG in the code to turn it on.
4903 C
4904         write (2,*) "sumene               =",sumene
4905         aincr=1.0d-7
4906         xxsave=xx
4907         xx=xx+aincr
4908         write (2,*) xx,yy,zz
4909         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4910         de_dxx_num=(sumenep-sumene)/aincr
4911         xx=xxsave
4912         write (2,*) "xx+ sumene from enesc=",sumenep
4913         yysave=yy
4914         yy=yy+aincr
4915         write (2,*) xx,yy,zz
4916         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4917         de_dyy_num=(sumenep-sumene)/aincr
4918         yy=yysave
4919         write (2,*) "yy+ sumene from enesc=",sumenep
4920         zzsave=zz
4921         zz=zz+aincr
4922         write (2,*) xx,yy,zz
4923         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4924         de_dzz_num=(sumenep-sumene)/aincr
4925         zz=zzsave
4926         write (2,*) "zz+ sumene from enesc=",sumenep
4927         costsave=cost2tab(i+1)
4928         sintsave=sint2tab(i+1)
4929         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4930         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4931         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4932         de_dt_num=(sumenep-sumene)/aincr
4933         write (2,*) " t+ sumene from enesc=",sumenep
4934         cost2tab(i+1)=costsave
4935         sint2tab(i+1)=sintsave
4936 C End of diagnostics section.
4937 #endif
4938 C
4939 C Compute the gradient of esc
4940 C
4941         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4942         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4943         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4944         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4945         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4946         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4947         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4948         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4949         pom1=(sumene3*sint2tab(i+1)+sumene1)
4950      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4951         pom2=(sumene4*cost2tab(i+1)+sumene2)
4952      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4953         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4954         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4955      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4956      &  +x(40)*yy*zz
4957         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4958         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4959      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4960      &  +x(60)*yy*zz
4961         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4962      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4963      &        +(pom1+pom2)*pom_dx
4964 #ifdef DEBUG
4965         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4966 #endif
4967 C
4968         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4969         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4970      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4971      &  +x(40)*xx*zz
4972         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4973         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4974      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4975      &  +x(59)*zz**2 +x(60)*xx*zz
4976         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4977      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4978      &        +(pom1-pom2)*pom_dy
4979 #ifdef DEBUG
4980         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4981 #endif
4982 C
4983         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4984      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4985      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4986      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4987      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4988      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4989      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4990      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4991 #ifdef DEBUG
4992         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4993 #endif
4994 C
4995         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4996      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4997      &  +pom1*pom_dt1+pom2*pom_dt2
4998 #ifdef DEBUG
4999         write(2,*), "de_dt = ", de_dt,de_dt_num
5000 #endif
5001 c
5002 C
5003        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5004        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5005        cosfac2xx=cosfac2*xx
5006        sinfac2yy=sinfac2*yy
5007        do k = 1,3
5008          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5009      &      vbld_inv(i+1)
5010          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5011      &      vbld_inv(i)
5012          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5013          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5014 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5015 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5016 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5017 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5018          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5019          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5020          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5021          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5022          dZZ_Ci1(k)=0.0d0
5023          dZZ_Ci(k)=0.0d0
5024          do j=1,3
5025            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5026      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5027            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5028      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5029          enddo
5030
5031          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5032          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5033          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5034 c
5035          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5036          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5037        enddo
5038
5039        do k=1,3
5040          dXX_Ctab(k,i)=dXX_Ci(k)
5041          dXX_C1tab(k,i)=dXX_Ci1(k)
5042          dYY_Ctab(k,i)=dYY_Ci(k)
5043          dYY_C1tab(k,i)=dYY_Ci1(k)
5044          dZZ_Ctab(k,i)=dZZ_Ci(k)
5045          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5046          dXX_XYZtab(k,i)=dXX_XYZ(k)
5047          dYY_XYZtab(k,i)=dYY_XYZ(k)
5048          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5049        enddo
5050
5051        do k = 1,3
5052 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5053 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5054 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5055 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5056 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5057 c     &    dt_dci(k)
5058 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5059 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5060          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5061      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5062          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5063      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5064          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5065      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5066        enddo
5067 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5068 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5069
5070 C to check gradient call subroutine check_grad
5071
5072     1 continue
5073       enddo
5074       return
5075       end
5076 #endif
5077 c------------------------------------------------------------------------------
5078       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5079 C
5080 C This procedure calculates two-body contact function g(rij) and its derivative:
5081 C
5082 C           eps0ij                                     !       x < -1
5083 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5084 C            0                                         !       x > 1
5085 C
5086 C where x=(rij-r0ij)/delta
5087 C
5088 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5089 C
5090       implicit none
5091       double precision rij,r0ij,eps0ij,fcont,fprimcont
5092       double precision x,x2,x4,delta
5093 c     delta=0.02D0*r0ij
5094 c      delta=0.2D0*r0ij
5095       x=(rij-r0ij)/delta
5096       if (x.lt.-1.0D0) then
5097         fcont=eps0ij
5098         fprimcont=0.0D0
5099       else if (x.le.1.0D0) then
5100         x2=x*x
5101         x4=x2*x2
5102         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5103         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5104       else
5105         fcont=0.0D0
5106         fprimcont=0.0D0
5107       endif
5108       return
5109       end
5110 c------------------------------------------------------------------------------
5111       subroutine splinthet(theti,delta,ss,ssder)
5112       implicit real*8 (a-h,o-z)
5113       include 'DIMENSIONS'
5114       include 'DIMENSIONS.ZSCOPT'
5115       include 'COMMON.VAR'
5116       include 'COMMON.GEO'
5117       thetup=pi-delta
5118       thetlow=delta
5119       if (theti.gt.pipol) then
5120         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5121       else
5122         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5123         ssder=-ssder
5124       endif
5125       return
5126       end
5127 c------------------------------------------------------------------------------
5128       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5129       implicit none
5130       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5131       double precision ksi,ksi2,ksi3,a1,a2,a3
5132       a1=fprim0*delta/(f1-f0)
5133       a2=3.0d0-2.0d0*a1
5134       a3=a1-2.0d0
5135       ksi=(x-x0)/delta
5136       ksi2=ksi*ksi
5137       ksi3=ksi2*ksi
5138       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5139       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5140       return
5141       end
5142 c------------------------------------------------------------------------------
5143       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5144       implicit none
5145       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5146       double precision ksi,ksi2,ksi3,a1,a2,a3
5147       ksi=(x-x0)/delta
5148       ksi2=ksi*ksi
5149       ksi3=ksi2*ksi
5150       a1=fprim0x*delta
5151       a2=3*(f1x-f0x)-2*fprim0x*delta
5152       a3=fprim0x*delta-2*(f1x-f0x)
5153       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5154       return
5155       end
5156 C-----------------------------------------------------------------------------
5157 #ifdef CRYST_TOR
5158 C-----------------------------------------------------------------------------
5159       subroutine etor(etors,edihcnstr,fact)
5160       implicit real*8 (a-h,o-z)
5161       include 'DIMENSIONS'
5162       include 'DIMENSIONS.ZSCOPT'
5163       include 'COMMON.VAR'
5164       include 'COMMON.GEO'
5165       include 'COMMON.LOCAL'
5166       include 'COMMON.TORSION'
5167       include 'COMMON.INTERACT'
5168       include 'COMMON.DERIV'
5169       include 'COMMON.CHAIN'
5170       include 'COMMON.NAMES'
5171       include 'COMMON.IOUNITS'
5172       include 'COMMON.FFIELD'
5173       include 'COMMON.TORCNSTR'
5174       logical lprn
5175 C Set lprn=.true. for debugging
5176       lprn=.false.
5177 c      lprn=.true.
5178       etors=0.0D0
5179       do i=iphi_start,iphi_end
5180         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5181      &      .or. itype(i).eq.ntyp1) cycle
5182         itori=itortyp(itype(i-2))
5183         itori1=itortyp(itype(i-1))
5184         phii=phi(i)
5185         gloci=0.0D0
5186 C Proline-Proline pair is a special case...
5187         if (itori.eq.3 .and. itori1.eq.3) then
5188           if (phii.gt.-dwapi3) then
5189             cosphi=dcos(3*phii)
5190             fac=1.0D0/(1.0D0-cosphi)
5191             etorsi=v1(1,3,3)*fac
5192             etorsi=etorsi+etorsi
5193             etors=etors+etorsi-v1(1,3,3)
5194             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5195           endif
5196           do j=1,3
5197             v1ij=v1(j+1,itori,itori1)
5198             v2ij=v2(j+1,itori,itori1)
5199             cosphi=dcos(j*phii)
5200             sinphi=dsin(j*phii)
5201             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5202             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5203           enddo
5204         else
5205           do j=1,nterm_old
5206             v1ij=v1(j,itori,itori1)
5207             v2ij=v2(j,itori,itori1)
5208             cosphi=dcos(j*phii)
5209             sinphi=dsin(j*phii)
5210             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5211             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5212           enddo
5213         endif
5214         if (lprn)
5215      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5216      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5217      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5218         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5219 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5220       enddo
5221 ! 6/20/98 - dihedral angle constraints
5222       edihcnstr=0.0d0
5223       do i=1,ndih_constr
5224         itori=idih_constr(i)
5225         phii=phi(itori)
5226         difi=phii-phi0(i)
5227         if (difi.gt.drange(i)) then
5228           difi=difi-drange(i)
5229           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5230           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5231         else if (difi.lt.-drange(i)) then
5232           difi=difi+drange(i)
5233           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5234           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5235         endif
5236 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5237 C     &    i,itori,rad2deg*phii,
5238 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5239       enddo
5240 !      write (iout,*) 'edihcnstr',edihcnstr
5241       return
5242       end
5243 c------------------------------------------------------------------------------
5244 #else
5245       subroutine etor(etors,edihcnstr,fact)
5246       implicit real*8 (a-h,o-z)
5247       include 'DIMENSIONS'
5248       include 'DIMENSIONS.ZSCOPT'
5249       include 'COMMON.VAR'
5250       include 'COMMON.GEO'
5251       include 'COMMON.LOCAL'
5252       include 'COMMON.TORSION'
5253       include 'COMMON.INTERACT'
5254       include 'COMMON.DERIV'
5255       include 'COMMON.CHAIN'
5256       include 'COMMON.NAMES'
5257       include 'COMMON.IOUNITS'
5258       include 'COMMON.FFIELD'
5259       include 'COMMON.TORCNSTR'
5260       logical lprn
5261 C Set lprn=.true. for debugging
5262       lprn=.false.
5263 c      lprn=.true.
5264       etors=0.0D0
5265       do i=iphi_start,iphi_end
5266         if (i.le.2) cycle
5267         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5268      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5269 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5270 C     &       .or. itype(i).eq.ntyp1) cycle
5271         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5272          if (iabs(itype(i)).eq.20) then
5273          iblock=2
5274          else
5275          iblock=1
5276          endif
5277         itori=itortyp(itype(i-2))
5278         itori1=itortyp(itype(i-1))
5279         phii=phi(i)
5280         gloci=0.0D0
5281 C Regular cosine and sine terms
5282         do j=1,nterm(itori,itori1,iblock)
5283           v1ij=v1(j,itori,itori1,iblock)
5284           v2ij=v2(j,itori,itori1,iblock)
5285           cosphi=dcos(j*phii)
5286           sinphi=dsin(j*phii)
5287           etors=etors+v1ij*cosphi+v2ij*sinphi
5288           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5289         enddo
5290 C Lorentz terms
5291 C                         v1
5292 C  E = SUM ----------------------------------- - v1
5293 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5294 C
5295         cosphi=dcos(0.5d0*phii)
5296         sinphi=dsin(0.5d0*phii)
5297         do j=1,nlor(itori,itori1,iblock)
5298           vl1ij=vlor1(j,itori,itori1)
5299           vl2ij=vlor2(j,itori,itori1)
5300           vl3ij=vlor3(j,itori,itori1)
5301           pom=vl2ij*cosphi+vl3ij*sinphi
5302           pom1=1.0d0/(pom*pom+1.0d0)
5303           etors=etors+vl1ij*pom1
5304 c          if (energy_dec) etors_ii=etors_ii+
5305 c     &                vl1ij*pom1
5306           pom=-pom*pom1*pom1
5307           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5308         enddo
5309 C Subtract the constant term
5310         etors=etors-v0(itori,itori1,iblock)
5311         if (lprn)
5312      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5313      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5314      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5315         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5316 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5317  1215   continue
5318       enddo
5319 ! 6/20/98 - dihedral angle constraints
5320       edihcnstr=0.0d0
5321       do i=1,ndih_constr
5322         itori=idih_constr(i)
5323         phii=phi(itori)
5324         difi=pinorm(phii-phi0(i))
5325         edihi=0.0d0
5326         if (difi.gt.drange(i)) then
5327           difi=difi-drange(i)
5328           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5329           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5330           edihi=0.25d0*ftors(i)*difi**4
5331         else if (difi.lt.-drange(i)) then
5332           difi=difi+drange(i)
5333           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5334           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5335           edihi=0.25d0*ftors(i)*difi**4
5336         else
5337           difi=0.0d0
5338         endif
5339         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5340      &    i,itori,rad2deg*phii,
5341      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5342 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5343 c     &    drange(i),edihi
5344 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5345 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5346       enddo
5347 !      write (iout,*) 'edihcnstr',edihcnstr
5348       return
5349       end
5350 c----------------------------------------------------------------------------
5351       subroutine etor_d(etors_d,fact2)
5352 C 6/23/01 Compute double torsional energy
5353       implicit real*8 (a-h,o-z)
5354       include 'DIMENSIONS'
5355       include 'DIMENSIONS.ZSCOPT'
5356       include 'COMMON.VAR'
5357       include 'COMMON.GEO'
5358       include 'COMMON.LOCAL'
5359       include 'COMMON.TORSION'
5360       include 'COMMON.INTERACT'
5361       include 'COMMON.DERIV'
5362       include 'COMMON.CHAIN'
5363       include 'COMMON.NAMES'
5364       include 'COMMON.IOUNITS'
5365       include 'COMMON.FFIELD'
5366       include 'COMMON.TORCNSTR'
5367       logical lprn
5368 C Set lprn=.true. for debugging
5369       lprn=.false.
5370 c     lprn=.true.
5371       etors_d=0.0D0
5372       do i=iphi_start,iphi_end-1
5373         if (i.le.3) cycle
5374 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5375 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5376          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5377      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5378      &  (itype(i+1).eq.ntyp1)) cycle
5379         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5380      &     goto 1215
5381         itori=itortyp(itype(i-2))
5382         itori1=itortyp(itype(i-1))
5383         itori2=itortyp(itype(i))
5384         phii=phi(i)
5385         phii1=phi(i+1)
5386         gloci1=0.0D0
5387         gloci2=0.0D0
5388         iblock=1
5389         if (iabs(itype(i+1)).eq.20) iblock=2
5390 C Regular cosine and sine terms
5391         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5392           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5393           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5394           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5395           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5396           cosphi1=dcos(j*phii)
5397           sinphi1=dsin(j*phii)
5398           cosphi2=dcos(j*phii1)
5399           sinphi2=dsin(j*phii1)
5400           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5401      &     v2cij*cosphi2+v2sij*sinphi2
5402           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5403           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5404         enddo
5405         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5406           do l=1,k-1
5407             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5408             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5409             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5410             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5411             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5412             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5413             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5414             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5415             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5416      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5417             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5418      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5419             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5420      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5421           enddo
5422         enddo
5423         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5424         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5425  1215   continue
5426       enddo
5427       return
5428       end
5429 #endif
5430 c------------------------------------------------------------------------------
5431       subroutine eback_sc_corr(esccor)
5432 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5433 c        conformational states; temporarily implemented as differences
5434 c        between UNRES torsional potentials (dependent on three types of
5435 c        residues) and the torsional potentials dependent on all 20 types
5436 c        of residues computed from AM1 energy surfaces of terminally-blocked
5437 c        amino-acid residues.
5438       implicit real*8 (a-h,o-z)
5439       include 'DIMENSIONS'
5440       include 'DIMENSIONS.ZSCOPT'
5441       include 'COMMON.VAR'
5442       include 'COMMON.GEO'
5443       include 'COMMON.LOCAL'
5444       include 'COMMON.TORSION'
5445       include 'COMMON.SCCOR'
5446       include 'COMMON.INTERACT'
5447       include 'COMMON.DERIV'
5448       include 'COMMON.CHAIN'
5449       include 'COMMON.NAMES'
5450       include 'COMMON.IOUNITS'
5451       include 'COMMON.FFIELD'
5452       include 'COMMON.CONTROL'
5453       logical lprn
5454 C Set lprn=.true. for debugging
5455       lprn=.false.
5456 c      lprn=.true.
5457 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5458       esccor=0.0D0
5459       do i=itau_start,itau_end
5460         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5461         esccor_ii=0.0D0
5462         isccori=isccortyp(itype(i-2))
5463         isccori1=isccortyp(itype(i-1))
5464         phii=phi(i)
5465         do intertyp=1,3 !intertyp
5466 cc Added 09 May 2012 (Adasko)
5467 cc  Intertyp means interaction type of backbone mainchain correlation:
5468 c   1 = SC...Ca...Ca...Ca
5469 c   2 = Ca...Ca...Ca...SC
5470 c   3 = SC...Ca...Ca...SCi
5471         gloci=0.0D0
5472         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5473      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5474      &      (itype(i-1).eq.ntyp1)))
5475      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5476      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5477      &     .or.(itype(i).eq.ntyp1)))
5478      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5479      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5480      &      (itype(i-3).eq.ntyp1)))) cycle
5481         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5482         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5483      & cycle
5484        do j=1,nterm_sccor(isccori,isccori1)
5485           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5486           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5487           cosphi=dcos(j*tauangle(intertyp,i))
5488           sinphi=dsin(j*tauangle(intertyp,i))
5489            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5490            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5491          enddo
5492 C      write (iout,*)"EBACK_SC_COR",esccor,i
5493 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5494 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5495 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5496         if (lprn)
5497      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5498      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5499      &  (v1sccor(j,1,itori,itori1),j=1,6)
5500      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5501 c        gsccor_loc(i-3)=gloci
5502        enddo !intertyp
5503       enddo
5504       return
5505       end
5506 c------------------------------------------------------------------------------
5507       subroutine multibody(ecorr)
5508 C This subroutine calculates multi-body contributions to energy following
5509 C the idea of Skolnick et al. If side chains I and J make a contact and
5510 C at the same time side chains I+1 and J+1 make a contact, an extra
5511 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5512       implicit real*8 (a-h,o-z)
5513       include 'DIMENSIONS'
5514       include 'COMMON.IOUNITS'
5515       include 'COMMON.DERIV'
5516       include 'COMMON.INTERACT'
5517       include 'COMMON.CONTACTS'
5518       double precision gx(3),gx1(3)
5519       logical lprn
5520
5521 C Set lprn=.true. for debugging
5522       lprn=.false.
5523
5524       if (lprn) then
5525         write (iout,'(a)') 'Contact function values:'
5526         do i=nnt,nct-2
5527           write (iout,'(i2,20(1x,i2,f10.5))')
5528      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5529         enddo
5530       endif
5531       ecorr=0.0D0
5532       do i=nnt,nct
5533         do j=1,3
5534           gradcorr(j,i)=0.0D0
5535           gradxorr(j,i)=0.0D0
5536         enddo
5537       enddo
5538       do i=nnt,nct-2
5539
5540         DO ISHIFT = 3,4
5541
5542         i1=i+ishift
5543         num_conti=num_cont(i)
5544         num_conti1=num_cont(i1)
5545         do jj=1,num_conti
5546           j=jcont(jj,i)
5547           do kk=1,num_conti1
5548             j1=jcont(kk,i1)
5549             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5550 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5551 cd   &                   ' ishift=',ishift
5552 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5553 C The system gains extra energy.
5554               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5555             endif   ! j1==j+-ishift
5556           enddo     ! kk
5557         enddo       ! jj
5558
5559         ENDDO ! ISHIFT
5560
5561       enddo         ! i
5562       return
5563       end
5564 c------------------------------------------------------------------------------
5565       double precision function esccorr(i,j,k,l,jj,kk)
5566       implicit real*8 (a-h,o-z)
5567       include 'DIMENSIONS'
5568       include 'COMMON.IOUNITS'
5569       include 'COMMON.DERIV'
5570       include 'COMMON.INTERACT'
5571       include 'COMMON.CONTACTS'
5572       double precision gx(3),gx1(3)
5573       logical lprn
5574       lprn=.false.
5575       eij=facont(jj,i)
5576       ekl=facont(kk,k)
5577 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5578 C Calculate the multi-body contribution to energy.
5579 C Calculate multi-body contributions to the gradient.
5580 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5581 cd   & k,l,(gacont(m,kk,k),m=1,3)
5582       do m=1,3
5583         gx(m) =ekl*gacont(m,jj,i)
5584         gx1(m)=eij*gacont(m,kk,k)
5585         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5586         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5587         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5588         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5589       enddo
5590       do m=i,j-1
5591         do ll=1,3
5592           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5593         enddo
5594       enddo
5595       do m=k,l-1
5596         do ll=1,3
5597           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5598         enddo
5599       enddo
5600       esccorr=-eij*ekl
5601       return
5602       end
5603 c------------------------------------------------------------------------------
5604 #ifdef MPL
5605       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5606       implicit real*8 (a-h,o-z)
5607       include 'DIMENSIONS'
5608       integer dimen1,dimen2,atom,indx
5609       double precision buffer(dimen1,dimen2)
5610       double precision zapas
5611       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5612      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5613      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5614       num_kont=num_cont_hb(atom)
5615       do i=1,num_kont
5616         do k=1,7
5617           do j=1,3
5618             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5619           enddo ! j
5620         enddo ! k
5621         buffer(i,indx+22)=facont_hb(i,atom)
5622         buffer(i,indx+23)=ees0p(i,atom)
5623         buffer(i,indx+24)=ees0m(i,atom)
5624         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5625       enddo ! i
5626       buffer(1,indx+26)=dfloat(num_kont)
5627       return
5628       end
5629 c------------------------------------------------------------------------------
5630       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5631       implicit real*8 (a-h,o-z)
5632       include 'DIMENSIONS'
5633       integer dimen1,dimen2,atom,indx
5634       double precision buffer(dimen1,dimen2)
5635       double precision zapas
5636       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5637      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5638      &         ees0m(ntyp,maxres),
5639      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5640       num_kont=buffer(1,indx+26)
5641       num_kont_old=num_cont_hb(atom)
5642       num_cont_hb(atom)=num_kont+num_kont_old
5643       do i=1,num_kont
5644         ii=i+num_kont_old
5645         do k=1,7
5646           do j=1,3
5647             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5648           enddo ! j
5649         enddo ! k
5650         facont_hb(ii,atom)=buffer(i,indx+22)
5651         ees0p(ii,atom)=buffer(i,indx+23)
5652         ees0m(ii,atom)=buffer(i,indx+24)
5653         jcont_hb(ii,atom)=buffer(i,indx+25)
5654       enddo ! i
5655       return
5656       end
5657 c------------------------------------------------------------------------------
5658 #endif
5659       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5660 C This subroutine calculates multi-body contributions to hydrogen-bonding
5661       implicit real*8 (a-h,o-z)
5662       include 'DIMENSIONS'
5663       include 'DIMENSIONS.ZSCOPT'
5664       include 'COMMON.IOUNITS'
5665 #ifdef MPL
5666       include 'COMMON.INFO'
5667 #endif
5668       include 'COMMON.FFIELD'
5669       include 'COMMON.DERIV'
5670       include 'COMMON.INTERACT'
5671       include 'COMMON.CONTACTS'
5672 #ifdef MPL
5673       parameter (max_cont=maxconts)
5674       parameter (max_dim=2*(8*3+2))
5675       parameter (msglen1=max_cont*max_dim*4)
5676       parameter (msglen2=2*msglen1)
5677       integer source,CorrelType,CorrelID,Error
5678       double precision buffer(max_cont,max_dim)
5679 #endif
5680       double precision gx(3),gx1(3)
5681       logical lprn,ldone
5682
5683 C Set lprn=.true. for debugging
5684       lprn=.false.
5685 #ifdef MPL
5686       n_corr=0
5687       n_corr1=0
5688       if (fgProcs.le.1) goto 30
5689       if (lprn) then
5690         write (iout,'(a)') 'Contact function values:'
5691         do i=nnt,nct-2
5692           write (iout,'(2i3,50(1x,i2,f5.2))')
5693      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5694      &    j=1,num_cont_hb(i))
5695         enddo
5696       endif
5697 C Caution! Following code assumes that electrostatic interactions concerning
5698 C a given atom are split among at most two processors!
5699       CorrelType=477
5700       CorrelID=MyID+1
5701       ldone=.false.
5702       do i=1,max_cont
5703         do j=1,max_dim
5704           buffer(i,j)=0.0D0
5705         enddo
5706       enddo
5707       mm=mod(MyRank,2)
5708 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5709       if (mm) 20,20,10
5710    10 continue
5711 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5712       if (MyRank.gt.0) then
5713 C Send correlation contributions to the preceding processor
5714         msglen=msglen1
5715         nn=num_cont_hb(iatel_s)
5716         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5717 cd      write (iout,*) 'The BUFFER array:'
5718 cd      do i=1,nn
5719 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5720 cd      enddo
5721         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5722           msglen=msglen2
5723             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5724 C Clear the contacts of the atom passed to the neighboring processor
5725         nn=num_cont_hb(iatel_s+1)
5726 cd      do i=1,nn
5727 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5728 cd      enddo
5729             num_cont_hb(iatel_s)=0
5730         endif
5731 cd      write (iout,*) 'Processor ',MyID,MyRank,
5732 cd   & ' is sending correlation contribution to processor',MyID-1,
5733 cd   & ' msglen=',msglen
5734 cd      write (*,*) 'Processor ',MyID,MyRank,
5735 cd   & ' is sending correlation contribution to processor',MyID-1,
5736 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5737         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5738 cd      write (iout,*) 'Processor ',MyID,
5739 cd   & ' has sent correlation contribution to processor',MyID-1,
5740 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5741 cd      write (*,*) 'Processor ',MyID,
5742 cd   & ' has sent correlation contribution to processor',MyID-1,
5743 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5744         msglen=msglen1
5745       endif ! (MyRank.gt.0)
5746       if (ldone) goto 30
5747       ldone=.true.
5748    20 continue
5749 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5750       if (MyRank.lt.fgProcs-1) then
5751 C Receive correlation contributions from the next processor
5752         msglen=msglen1
5753         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5754 cd      write (iout,*) 'Processor',MyID,
5755 cd   & ' is receiving correlation contribution from processor',MyID+1,
5756 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5757 cd      write (*,*) 'Processor',MyID,
5758 cd   & ' is receiving correlation contribution from processor',MyID+1,
5759 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5760         nbytes=-1
5761         do while (nbytes.le.0)
5762           call mp_probe(MyID+1,CorrelType,nbytes)
5763         enddo
5764 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5765         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5766 cd      write (iout,*) 'Processor',MyID,
5767 cd   & ' has received correlation contribution from processor',MyID+1,
5768 cd   & ' msglen=',msglen,' nbytes=',nbytes
5769 cd      write (iout,*) 'The received BUFFER array:'
5770 cd      do i=1,max_cont
5771 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5772 cd      enddo
5773         if (msglen.eq.msglen1) then
5774           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5775         else if (msglen.eq.msglen2)  then
5776           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5777           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5778         else
5779           write (iout,*)
5780      & 'ERROR!!!! message length changed while processing correlations.'
5781           write (*,*)
5782      & 'ERROR!!!! message length changed while processing correlations.'
5783           call mp_stopall(Error)
5784         endif ! msglen.eq.msglen1
5785       endif ! MyRank.lt.fgProcs-1
5786       if (ldone) goto 30
5787       ldone=.true.
5788       goto 10
5789    30 continue
5790 #endif
5791       if (lprn) then
5792         write (iout,'(a)') 'Contact function values:'
5793         do i=nnt,nct-2
5794           write (iout,'(2i3,50(1x,i2,f5.2))')
5795      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5796      &    j=1,num_cont_hb(i))
5797         enddo
5798       endif
5799       ecorr=0.0D0
5800 C Remove the loop below after debugging !!!
5801       do i=nnt,nct
5802         do j=1,3
5803           gradcorr(j,i)=0.0D0
5804           gradxorr(j,i)=0.0D0
5805         enddo
5806       enddo
5807 C Calculate the local-electrostatic correlation terms
5808       do i=iatel_s,iatel_e+1
5809         i1=i+1
5810         num_conti=num_cont_hb(i)
5811         num_conti1=num_cont_hb(i+1)
5812         do jj=1,num_conti
5813           j=jcont_hb(jj,i)
5814           do kk=1,num_conti1
5815             j1=jcont_hb(kk,i1)
5816 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5817 c     &         ' jj=',jj,' kk=',kk
5818             if (j1.eq.j+1 .or. j1.eq.j-1) then
5819 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5820 C The system gains extra energy.
5821               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5822               n_corr=n_corr+1
5823             else if (j1.eq.j) then
5824 C Contacts I-J and I-(J+1) occur simultaneously.
5825 C The system loses extra energy.
5826 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5827             endif
5828           enddo ! kk
5829           do kk=1,num_conti
5830             j1=jcont_hb(kk,i)
5831 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5832 c    &         ' jj=',jj,' kk=',kk
5833             if (j1.eq.j+1) then
5834 C Contacts I-J and (I+1)-J occur simultaneously.
5835 C The system loses extra energy.
5836 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5837             endif ! j1==j+1
5838           enddo ! kk
5839         enddo ! jj
5840       enddo ! i
5841       return
5842       end
5843 c------------------------------------------------------------------------------
5844       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5845      &  n_corr1)
5846 C This subroutine calculates multi-body contributions to hydrogen-bonding
5847       implicit real*8 (a-h,o-z)
5848       include 'DIMENSIONS'
5849       include 'DIMENSIONS.ZSCOPT'
5850       include 'COMMON.IOUNITS'
5851 #ifdef MPL
5852       include 'COMMON.INFO'
5853 #endif
5854       include 'COMMON.FFIELD'
5855       include 'COMMON.DERIV'
5856       include 'COMMON.INTERACT'
5857       include 'COMMON.CONTACTS'
5858 #ifdef MPL
5859       parameter (max_cont=maxconts)
5860       parameter (max_dim=2*(8*3+2))
5861       parameter (msglen1=max_cont*max_dim*4)
5862       parameter (msglen2=2*msglen1)
5863       integer source,CorrelType,CorrelID,Error
5864       double precision buffer(max_cont,max_dim)
5865 #endif
5866       double precision gx(3),gx1(3)
5867       logical lprn,ldone
5868
5869 C Set lprn=.true. for debugging
5870       lprn=.false.
5871       eturn6=0.0d0
5872       ecorr6=0.0d0
5873 #ifdef MPL
5874       n_corr=0
5875       n_corr1=0
5876       if (fgProcs.le.1) goto 30
5877       if (lprn) then
5878         write (iout,'(a)') 'Contact function values:'
5879         do i=nnt,nct-2
5880           write (iout,'(2i3,50(1x,i2,f5.2))')
5881      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5882      &    j=1,num_cont_hb(i))
5883         enddo
5884       endif
5885 C Caution! Following code assumes that electrostatic interactions concerning
5886 C a given atom are split among at most two processors!
5887       CorrelType=477
5888       CorrelID=MyID+1
5889       ldone=.false.
5890       do i=1,max_cont
5891         do j=1,max_dim
5892           buffer(i,j)=0.0D0
5893         enddo
5894       enddo
5895       mm=mod(MyRank,2)
5896 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5897       if (mm) 20,20,10
5898    10 continue
5899 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5900       if (MyRank.gt.0) then
5901 C Send correlation contributions to the preceding processor
5902         msglen=msglen1
5903         nn=num_cont_hb(iatel_s)
5904         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5905 cd      write (iout,*) 'The BUFFER array:'
5906 cd      do i=1,nn
5907 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5908 cd      enddo
5909         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5910           msglen=msglen2
5911             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5912 C Clear the contacts of the atom passed to the neighboring processor
5913         nn=num_cont_hb(iatel_s+1)
5914 cd      do i=1,nn
5915 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5916 cd      enddo
5917             num_cont_hb(iatel_s)=0
5918         endif
5919 cd      write (iout,*) 'Processor ',MyID,MyRank,
5920 cd   & ' is sending correlation contribution to processor',MyID-1,
5921 cd   & ' msglen=',msglen
5922 cd      write (*,*) 'Processor ',MyID,MyRank,
5923 cd   & ' is sending correlation contribution to processor',MyID-1,
5924 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5925         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5926 cd      write (iout,*) 'Processor ',MyID,
5927 cd   & ' has sent correlation contribution to processor',MyID-1,
5928 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5929 cd      write (*,*) 'Processor ',MyID,
5930 cd   & ' has sent correlation contribution to processor',MyID-1,
5931 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5932         msglen=msglen1
5933       endif ! (MyRank.gt.0)
5934       if (ldone) goto 30
5935       ldone=.true.
5936    20 continue
5937 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5938       if (MyRank.lt.fgProcs-1) then
5939 C Receive correlation contributions from the next processor
5940         msglen=msglen1
5941         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5942 cd      write (iout,*) 'Processor',MyID,
5943 cd   & ' is receiving correlation contribution from processor',MyID+1,
5944 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5945 cd      write (*,*) 'Processor',MyID,
5946 cd   & ' is receiving correlation contribution from processor',MyID+1,
5947 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5948         nbytes=-1
5949         do while (nbytes.le.0)
5950           call mp_probe(MyID+1,CorrelType,nbytes)
5951         enddo
5952 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5953         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5954 cd      write (iout,*) 'Processor',MyID,
5955 cd   & ' has received correlation contribution from processor',MyID+1,
5956 cd   & ' msglen=',msglen,' nbytes=',nbytes
5957 cd      write (iout,*) 'The received BUFFER array:'
5958 cd      do i=1,max_cont
5959 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5960 cd      enddo
5961         if (msglen.eq.msglen1) then
5962           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5963         else if (msglen.eq.msglen2)  then
5964           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5965           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5966         else
5967           write (iout,*)
5968      & 'ERROR!!!! message length changed while processing correlations.'
5969           write (*,*)
5970      & 'ERROR!!!! message length changed while processing correlations.'
5971           call mp_stopall(Error)
5972         endif ! msglen.eq.msglen1
5973       endif ! MyRank.lt.fgProcs-1
5974       if (ldone) goto 30
5975       ldone=.true.
5976       goto 10
5977    30 continue
5978 #endif
5979       if (lprn) then
5980         write (iout,'(a)') 'Contact function values:'
5981         do i=nnt,nct-2
5982           write (iout,'(2i3,50(1x,i2,f5.2))')
5983      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5984      &    j=1,num_cont_hb(i))
5985         enddo
5986       endif
5987       ecorr=0.0D0
5988       ecorr5=0.0d0
5989       ecorr6=0.0d0
5990 C Remove the loop below after debugging !!!
5991       do i=nnt,nct
5992         do j=1,3
5993           gradcorr(j,i)=0.0D0
5994           gradxorr(j,i)=0.0D0
5995         enddo
5996       enddo
5997 C Calculate the dipole-dipole interaction energies
5998       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5999       do i=iatel_s,iatel_e+1
6000         num_conti=num_cont_hb(i)
6001         do jj=1,num_conti
6002           j=jcont_hb(jj,i)
6003           call dipole(i,j,jj)
6004         enddo
6005       enddo
6006       endif
6007 C Calculate the local-electrostatic correlation terms
6008       do i=iatel_s,iatel_e+1
6009         i1=i+1
6010         num_conti=num_cont_hb(i)
6011         num_conti1=num_cont_hb(i+1)
6012         do jj=1,num_conti
6013           j=jcont_hb(jj,i)
6014           do kk=1,num_conti1
6015             j1=jcont_hb(kk,i1)
6016 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6017 c     &         ' jj=',jj,' kk=',kk
6018             if (j1.eq.j+1 .or. j1.eq.j-1) then
6019 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6020 C The system gains extra energy.
6021               n_corr=n_corr+1
6022               sqd1=dsqrt(d_cont(jj,i))
6023               sqd2=dsqrt(d_cont(kk,i1))
6024               sred_geom = sqd1*sqd2
6025               IF (sred_geom.lt.cutoff_corr) THEN
6026                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6027      &            ekont,fprimcont)
6028 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6029 c     &         ' jj=',jj,' kk=',kk
6030                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6031                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6032                 do l=1,3
6033                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6034                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6035                 enddo
6036                 n_corr1=n_corr1+1
6037 cd               write (iout,*) 'sred_geom=',sred_geom,
6038 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6039                 call calc_eello(i,j,i+1,j1,jj,kk)
6040                 if (wcorr4.gt.0.0d0)
6041      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6042                 if (wcorr5.gt.0.0d0)
6043      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6044 c                print *,"wcorr5",ecorr5
6045 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6046 cd                write(2,*)'ijkl',i,j,i+1,j1
6047                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6048      &               .or. wturn6.eq.0.0d0))then
6049 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6050                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6051 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6052 cd     &            'ecorr6=',ecorr6
6053 cd                write (iout,'(4e15.5)') sred_geom,
6054 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6055 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6056 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6057                 else if (wturn6.gt.0.0d0
6058      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6059 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6060                   eturn6=eturn6+eello_turn6(i,jj,kk)
6061 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6062                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6063                    eturn6=0.0d0
6064                    ecorr6=0.0d0
6065                 endif
6066
6067               ENDIF
6068 1111          continue
6069             else if (j1.eq.j) then
6070 C Contacts I-J and I-(J+1) occur simultaneously.
6071 C The system loses extra energy.
6072 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6073             endif
6074           enddo ! kk
6075           do kk=1,num_conti
6076             j1=jcont_hb(kk,i)
6077 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6078 c    &         ' jj=',jj,' kk=',kk
6079             if (j1.eq.j+1) then
6080 C Contacts I-J and (I+1)-J occur simultaneously.
6081 C The system loses extra energy.
6082 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6083             endif ! j1==j+1
6084           enddo ! kk
6085         enddo ! jj
6086       enddo ! i
6087       write (iout,*) "eturn6",eturn6,ecorr6
6088       return
6089       end
6090 c------------------------------------------------------------------------------
6091       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6092       implicit real*8 (a-h,o-z)
6093       include 'DIMENSIONS'
6094       include 'COMMON.IOUNITS'
6095       include 'COMMON.DERIV'
6096       include 'COMMON.INTERACT'
6097       include 'COMMON.CONTACTS'
6098       include 'COMMON.CONTROL'
6099       include 'COMMON.SHIELD'
6100       double precision gx(3),gx1(3)
6101       logical lprn
6102       lprn=.false.
6103       eij=facont_hb(jj,i)
6104       ekl=facont_hb(kk,k)
6105       ees0pij=ees0p(jj,i)
6106       ees0pkl=ees0p(kk,k)
6107       ees0mij=ees0m(jj,i)
6108       ees0mkl=ees0m(kk,k)
6109       ekont=eij*ekl
6110       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6111 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6112 C Following 4 lines for diagnostics.
6113 cd    ees0pkl=0.0D0
6114 cd    ees0pij=1.0D0
6115 cd    ees0mkl=0.0D0
6116 cd    ees0mij=1.0D0
6117 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6118 c    &   ' and',k,l
6119 c     write (iout,*)'Contacts have occurred for peptide groups',
6120 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6121 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6122 C Calculate the multi-body contribution to energy.
6123 C      ecorr=ecorr+ekont*ees
6124       if (calc_grad) then
6125 C Calculate multi-body contributions to the gradient.
6126       do ll=1,3
6127         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6128         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6129      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6130      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6131         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6132      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6133      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6134         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6135         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6136      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6137      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6138         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6139      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6140      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6141       enddo
6142       do m=i+1,j-1
6143         do ll=1,3
6144           gradcorr(ll,m)=gradcorr(ll,m)+
6145      &     ees*ekl*gacont_hbr(ll,jj,i)-
6146      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6147      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6148         enddo
6149       enddo
6150       do m=k+1,l-1
6151         do ll=1,3
6152           gradcorr(ll,m)=gradcorr(ll,m)+
6153      &     ees*eij*gacont_hbr(ll,kk,k)-
6154      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6155      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6156         enddo
6157       enddo
6158       if (shield_mode.gt.0) then
6159        j=ees0plist(jj,i)
6160        l=ees0plist(kk,k)
6161 C        print *,i,j,fac_shield(i),fac_shield(j),
6162 C     &fac_shield(k),fac_shield(l)
6163         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6164      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6165           do ilist=1,ishield_list(i)
6166            iresshield=shield_list(ilist,i)
6167            do m=1,3
6168            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6169 C     &      *2.0
6170            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6171      &              rlocshield
6172      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6173             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6174      &+rlocshield
6175            enddo
6176           enddo
6177           do ilist=1,ishield_list(j)
6178            iresshield=shield_list(ilist,j)
6179            do m=1,3
6180            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6181 C     &     *2.0
6182            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6183      &              rlocshield
6184      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6185            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6186      &     +rlocshield
6187            enddo
6188           enddo
6189           do ilist=1,ishield_list(k)
6190            iresshield=shield_list(ilist,k)
6191            do m=1,3
6192            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6193 C     &     *2.0
6194            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6195      &              rlocshield
6196      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6197            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6198      &     +rlocshield
6199            enddo
6200           enddo
6201           do ilist=1,ishield_list(l)
6202            iresshield=shield_list(ilist,l)
6203            do m=1,3
6204            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6205 C     &     *2.0
6206            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6207      &              rlocshield
6208      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6209            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6210      &     +rlocshield
6211            enddo
6212           enddo
6213 C          print *,gshieldx(m,iresshield)
6214           do m=1,3
6215             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6216      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6217             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6218      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6219             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6220      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6221             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6222      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6223
6224             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6225      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6226             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6227      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6228             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6229      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6230             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6231      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6232
6233            enddo
6234       endif
6235       endif
6236       endif
6237       ehbcorr=ekont*ees
6238       return
6239       end
6240 C---------------------------------------------------------------------------
6241       subroutine dipole(i,j,jj)
6242       implicit real*8 (a-h,o-z)
6243       include 'DIMENSIONS'
6244       include 'DIMENSIONS.ZSCOPT'
6245       include 'COMMON.IOUNITS'
6246       include 'COMMON.CHAIN'
6247       include 'COMMON.FFIELD'
6248       include 'COMMON.DERIV'
6249       include 'COMMON.INTERACT'
6250       include 'COMMON.CONTACTS'
6251       include 'COMMON.TORSION'
6252       include 'COMMON.VAR'
6253       include 'COMMON.GEO'
6254       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6255      &  auxmat(2,2)
6256       iti1 = itortyp(itype(i+1))
6257       if (j.lt.nres-1) then
6258         if (itype(j).le.ntyp) then
6259           itj1 = itortyp(itype(j+1))
6260         else
6261           itj=ntortyp+1
6262         endif
6263       else
6264         itj1=ntortyp+1
6265       endif
6266       do iii=1,2
6267         dipi(iii,1)=Ub2(iii,i)
6268         dipderi(iii)=Ub2der(iii,i)
6269         dipi(iii,2)=b1(iii,iti1)
6270         dipj(iii,1)=Ub2(iii,j)
6271         dipderj(iii)=Ub2der(iii,j)
6272         dipj(iii,2)=b1(iii,itj1)
6273       enddo
6274       kkk=0
6275       do iii=1,2
6276         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6277         do jjj=1,2
6278           kkk=kkk+1
6279           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6280         enddo
6281       enddo
6282       if (.not.calc_grad) return
6283       do kkk=1,5
6284         do lll=1,3
6285           mmm=0
6286           do iii=1,2
6287             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6288      &        auxvec(1))
6289             do jjj=1,2
6290               mmm=mmm+1
6291               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6292             enddo
6293           enddo
6294         enddo
6295       enddo
6296       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6297       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6298       do iii=1,2
6299         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6300       enddo
6301       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6302       do iii=1,2
6303         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6304       enddo
6305       return
6306       end
6307 C---------------------------------------------------------------------------
6308       subroutine calc_eello(i,j,k,l,jj,kk)
6309 C
6310 C This subroutine computes matrices and vectors needed to calculate
6311 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6312 C
6313       implicit real*8 (a-h,o-z)
6314       include 'DIMENSIONS'
6315       include 'DIMENSIONS.ZSCOPT'
6316       include 'COMMON.IOUNITS'
6317       include 'COMMON.CHAIN'
6318       include 'COMMON.DERIV'
6319       include 'COMMON.INTERACT'
6320       include 'COMMON.CONTACTS'
6321       include 'COMMON.TORSION'
6322       include 'COMMON.VAR'
6323       include 'COMMON.GEO'
6324       include 'COMMON.FFIELD'
6325       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6326      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6327       logical lprn
6328       common /kutas/ lprn
6329 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6330 cd     & ' jj=',jj,' kk=',kk
6331 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6332       do iii=1,2
6333         do jjj=1,2
6334           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6335           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6336         enddo
6337       enddo
6338       call transpose2(aa1(1,1),aa1t(1,1))
6339       call transpose2(aa2(1,1),aa2t(1,1))
6340       do kkk=1,5
6341         do lll=1,3
6342           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6343      &      aa1tder(1,1,lll,kkk))
6344           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6345      &      aa2tder(1,1,lll,kkk))
6346         enddo
6347       enddo
6348       if (l.eq.j+1) then
6349 C parallel orientation of the two CA-CA-CA frames.
6350         if (i.gt.1 .and. itype(i).le.ntyp) then
6351           iti=itortyp(itype(i))
6352         else
6353           iti=ntortyp+1
6354         endif
6355         itk1=itortyp(itype(k+1))
6356         itj=itortyp(itype(j))
6357         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6358           itl1=itortyp(itype(l+1))
6359         else
6360           itl1=ntortyp+1
6361         endif
6362 C A1 kernel(j+1) A2T
6363 cd        do iii=1,2
6364 cd          write (iout,'(3f10.5,5x,3f10.5)')
6365 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6366 cd        enddo
6367         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6368      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6369      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6370 C Following matrices are needed only for 6-th order cumulants
6371         IF (wcorr6.gt.0.0d0) THEN
6372         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6373      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6374      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6375         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6376      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6377      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6378      &   ADtEAderx(1,1,1,1,1,1))
6379         lprn=.false.
6380         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6381      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6382      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6383      &   ADtEA1derx(1,1,1,1,1,1))
6384         ENDIF
6385 C End 6-th order cumulants
6386 cd        lprn=.false.
6387 cd        if (lprn) then
6388 cd        write (2,*) 'In calc_eello6'
6389 cd        do iii=1,2
6390 cd          write (2,*) 'iii=',iii
6391 cd          do kkk=1,5
6392 cd            write (2,*) 'kkk=',kkk
6393 cd            do jjj=1,2
6394 cd              write (2,'(3(2f10.5),5x)')
6395 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6396 cd            enddo
6397 cd          enddo
6398 cd        enddo
6399 cd        endif
6400         call transpose2(EUgder(1,1,k),auxmat(1,1))
6401         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6402         call transpose2(EUg(1,1,k),auxmat(1,1))
6403         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6404         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6405         do iii=1,2
6406           do kkk=1,5
6407             do lll=1,3
6408               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6409      &          EAEAderx(1,1,lll,kkk,iii,1))
6410             enddo
6411           enddo
6412         enddo
6413 C A1T kernel(i+1) A2
6414         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6415      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6416      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6417 C Following matrices are needed only for 6-th order cumulants
6418         IF (wcorr6.gt.0.0d0) THEN
6419         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6420      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6421      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6422         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6423      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6424      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6425      &   ADtEAderx(1,1,1,1,1,2))
6426         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6427      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6428      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6429      &   ADtEA1derx(1,1,1,1,1,2))
6430         ENDIF
6431 C End 6-th order cumulants
6432         call transpose2(EUgder(1,1,l),auxmat(1,1))
6433         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6434         call transpose2(EUg(1,1,l),auxmat(1,1))
6435         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6436         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6437         do iii=1,2
6438           do kkk=1,5
6439             do lll=1,3
6440               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6441      &          EAEAderx(1,1,lll,kkk,iii,2))
6442             enddo
6443           enddo
6444         enddo
6445 C AEAb1 and AEAb2
6446 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6447 C They are needed only when the fifth- or the sixth-order cumulants are
6448 C indluded.
6449         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6450         call transpose2(AEA(1,1,1),auxmat(1,1))
6451         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6452         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6453         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6454         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6455         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6456         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6457         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6458         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6459         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6460         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6461         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6462         call transpose2(AEA(1,1,2),auxmat(1,1))
6463         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6464         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6465         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6466         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6467         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6468         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6469         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6470         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6471         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6472         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6473         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6474 C Calculate the Cartesian derivatives of the vectors.
6475         do iii=1,2
6476           do kkk=1,5
6477             do lll=1,3
6478               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6479               call matvec2(auxmat(1,1),b1(1,iti),
6480      &          AEAb1derx(1,lll,kkk,iii,1,1))
6481               call matvec2(auxmat(1,1),Ub2(1,i),
6482      &          AEAb2derx(1,lll,kkk,iii,1,1))
6483               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6484      &          AEAb1derx(1,lll,kkk,iii,2,1))
6485               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6486      &          AEAb2derx(1,lll,kkk,iii,2,1))
6487               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6488               call matvec2(auxmat(1,1),b1(1,itj),
6489      &          AEAb1derx(1,lll,kkk,iii,1,2))
6490               call matvec2(auxmat(1,1),Ub2(1,j),
6491      &          AEAb2derx(1,lll,kkk,iii,1,2))
6492               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6493      &          AEAb1derx(1,lll,kkk,iii,2,2))
6494               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6495      &          AEAb2derx(1,lll,kkk,iii,2,2))
6496             enddo
6497           enddo
6498         enddo
6499         ENDIF
6500 C End vectors
6501       else
6502 C Antiparallel orientation of the two CA-CA-CA frames.
6503         if (i.gt.1 .and. itype(i).le.ntyp) then
6504           iti=itortyp(itype(i))
6505         else
6506           iti=ntortyp+1
6507         endif
6508         itk1=itortyp(itype(k+1))
6509         itl=itortyp(itype(l))
6510         itj=itortyp(itype(j))
6511         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6512           itj1=itortyp(itype(j+1))
6513         else
6514           itj1=ntortyp+1
6515         endif
6516 C A2 kernel(j-1)T A1T
6517         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6518      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6519      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6520 C Following matrices are needed only for 6-th order cumulants
6521         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6522      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6523         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6524      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6525      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6526         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6527      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6528      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6529      &   ADtEAderx(1,1,1,1,1,1))
6530         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6531      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6532      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6533      &   ADtEA1derx(1,1,1,1,1,1))
6534         ENDIF
6535 C End 6-th order cumulants
6536         call transpose2(EUgder(1,1,k),auxmat(1,1))
6537         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6538         call transpose2(EUg(1,1,k),auxmat(1,1))
6539         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6540         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6541         do iii=1,2
6542           do kkk=1,5
6543             do lll=1,3
6544               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6545      &          EAEAderx(1,1,lll,kkk,iii,1))
6546             enddo
6547           enddo
6548         enddo
6549 C A2T kernel(i+1)T A1
6550         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6551      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6552      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6553 C Following matrices are needed only for 6-th order cumulants
6554         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6555      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6556         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6557      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6558      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6559         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6560      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6561      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6562      &   ADtEAderx(1,1,1,1,1,2))
6563         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6564      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6565      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6566      &   ADtEA1derx(1,1,1,1,1,2))
6567         ENDIF
6568 C End 6-th order cumulants
6569         call transpose2(EUgder(1,1,j),auxmat(1,1))
6570         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6571         call transpose2(EUg(1,1,j),auxmat(1,1))
6572         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6573         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6574         do iii=1,2
6575           do kkk=1,5
6576             do lll=1,3
6577               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6578      &          EAEAderx(1,1,lll,kkk,iii,2))
6579             enddo
6580           enddo
6581         enddo
6582 C AEAb1 and AEAb2
6583 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6584 C They are needed only when the fifth- or the sixth-order cumulants are
6585 C indluded.
6586         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6587      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6588         call transpose2(AEA(1,1,1),auxmat(1,1))
6589         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6590         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6591         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6592         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6593         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6594         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6595         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6596         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6597         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6598         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6599         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6600         call transpose2(AEA(1,1,2),auxmat(1,1))
6601         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6602         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6603         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6604         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6605         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6606         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6607         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6608         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6609         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6610         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6611         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6612 C Calculate the Cartesian derivatives of the vectors.
6613         do iii=1,2
6614           do kkk=1,5
6615             do lll=1,3
6616               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6617               call matvec2(auxmat(1,1),b1(1,iti),
6618      &          AEAb1derx(1,lll,kkk,iii,1,1))
6619               call matvec2(auxmat(1,1),Ub2(1,i),
6620      &          AEAb2derx(1,lll,kkk,iii,1,1))
6621               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6622      &          AEAb1derx(1,lll,kkk,iii,2,1))
6623               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6624      &          AEAb2derx(1,lll,kkk,iii,2,1))
6625               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6626               call matvec2(auxmat(1,1),b1(1,itl),
6627      &          AEAb1derx(1,lll,kkk,iii,1,2))
6628               call matvec2(auxmat(1,1),Ub2(1,l),
6629      &          AEAb2derx(1,lll,kkk,iii,1,2))
6630               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6631      &          AEAb1derx(1,lll,kkk,iii,2,2))
6632               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6633      &          AEAb2derx(1,lll,kkk,iii,2,2))
6634             enddo
6635           enddo
6636         enddo
6637         ENDIF
6638 C End vectors
6639       endif
6640       return
6641       end
6642 C---------------------------------------------------------------------------
6643       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6644      &  KK,KKderg,AKA,AKAderg,AKAderx)
6645       implicit none
6646       integer nderg
6647       logical transp
6648       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6649      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6650      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6651       integer iii,kkk,lll
6652       integer jjj,mmm
6653       logical lprn
6654       common /kutas/ lprn
6655       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6656       do iii=1,nderg
6657         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6658      &    AKAderg(1,1,iii))
6659       enddo
6660 cd      if (lprn) write (2,*) 'In kernel'
6661       do kkk=1,5
6662 cd        if (lprn) write (2,*) 'kkk=',kkk
6663         do lll=1,3
6664           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6665      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6666 cd          if (lprn) then
6667 cd            write (2,*) 'lll=',lll
6668 cd            write (2,*) 'iii=1'
6669 cd            do jjj=1,2
6670 cd              write (2,'(3(2f10.5),5x)')
6671 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6672 cd            enddo
6673 cd          endif
6674           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6675      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6676 cd          if (lprn) then
6677 cd            write (2,*) 'lll=',lll
6678 cd            write (2,*) 'iii=2'
6679 cd            do jjj=1,2
6680 cd              write (2,'(3(2f10.5),5x)')
6681 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6682 cd            enddo
6683 cd          endif
6684         enddo
6685       enddo
6686       return
6687       end
6688 C---------------------------------------------------------------------------
6689       double precision function eello4(i,j,k,l,jj,kk)
6690       implicit real*8 (a-h,o-z)
6691       include 'DIMENSIONS'
6692       include 'DIMENSIONS.ZSCOPT'
6693       include 'COMMON.IOUNITS'
6694       include 'COMMON.CHAIN'
6695       include 'COMMON.DERIV'
6696       include 'COMMON.INTERACT'
6697       include 'COMMON.CONTACTS'
6698       include 'COMMON.TORSION'
6699       include 'COMMON.VAR'
6700       include 'COMMON.GEO'
6701       double precision pizda(2,2),ggg1(3),ggg2(3)
6702 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6703 cd        eello4=0.0d0
6704 cd        return
6705 cd      endif
6706 cd      print *,'eello4:',i,j,k,l,jj,kk
6707 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6708 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6709 cold      eij=facont_hb(jj,i)
6710 cold      ekl=facont_hb(kk,k)
6711 cold      ekont=eij*ekl
6712       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6713       if (calc_grad) then
6714 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6715       gcorr_loc(k-1)=gcorr_loc(k-1)
6716      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6717       if (l.eq.j+1) then
6718         gcorr_loc(l-1)=gcorr_loc(l-1)
6719      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6720       else
6721         gcorr_loc(j-1)=gcorr_loc(j-1)
6722      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6723       endif
6724       do iii=1,2
6725         do kkk=1,5
6726           do lll=1,3
6727             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6728      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6729 cd            derx(lll,kkk,iii)=0.0d0
6730           enddo
6731         enddo
6732       enddo
6733 cd      gcorr_loc(l-1)=0.0d0
6734 cd      gcorr_loc(j-1)=0.0d0
6735 cd      gcorr_loc(k-1)=0.0d0
6736 cd      eel4=1.0d0
6737 cd      write (iout,*)'Contacts have occurred for peptide groups',
6738 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6739 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6740       if (j.lt.nres-1) then
6741         j1=j+1
6742         j2=j-1
6743       else
6744         j1=j-1
6745         j2=j-2
6746       endif
6747       if (l.lt.nres-1) then
6748         l1=l+1
6749         l2=l-1
6750       else
6751         l1=l-1
6752         l2=l-2
6753       endif
6754       do ll=1,3
6755 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6756         ggg1(ll)=eel4*g_contij(ll,1)
6757         ggg2(ll)=eel4*g_contij(ll,2)
6758         ghalf=0.5d0*ggg1(ll)
6759 cd        ghalf=0.0d0
6760         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6761         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6762         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6763         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6764 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6765         ghalf=0.5d0*ggg2(ll)
6766 cd        ghalf=0.0d0
6767         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6768         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6769         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6770         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6771       enddo
6772 cd      goto 1112
6773       do m=i+1,j-1
6774         do ll=1,3
6775 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6776           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6777         enddo
6778       enddo
6779       do m=k+1,l-1
6780         do ll=1,3
6781 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6782           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6783         enddo
6784       enddo
6785 1112  continue
6786       do m=i+2,j2
6787         do ll=1,3
6788           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6789         enddo
6790       enddo
6791       do m=k+2,l2
6792         do ll=1,3
6793           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6794         enddo
6795       enddo
6796 cd      do iii=1,nres-3
6797 cd        write (2,*) iii,gcorr_loc(iii)
6798 cd      enddo
6799       endif
6800       eello4=ekont*eel4
6801 cd      write (2,*) 'ekont',ekont
6802 cd      write (iout,*) 'eello4',ekont*eel4
6803       return
6804       end
6805 C---------------------------------------------------------------------------
6806       double precision function eello5(i,j,k,l,jj,kk)
6807       implicit real*8 (a-h,o-z)
6808       include 'DIMENSIONS'
6809       include 'DIMENSIONS.ZSCOPT'
6810       include 'COMMON.IOUNITS'
6811       include 'COMMON.CHAIN'
6812       include 'COMMON.DERIV'
6813       include 'COMMON.INTERACT'
6814       include 'COMMON.CONTACTS'
6815       include 'COMMON.TORSION'
6816       include 'COMMON.VAR'
6817       include 'COMMON.GEO'
6818       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6819       double precision ggg1(3),ggg2(3)
6820 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6821 C                                                                              C
6822 C                            Parallel chains                                   C
6823 C                                                                              C
6824 C          o             o                   o             o                   C
6825 C         /l\           / \             \   / \           / \   /              C
6826 C        /   \         /   \             \ /   \         /   \ /               C
6827 C       j| o |l1       | o |              o| o |         | o |o                C
6828 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6829 C      \i/   \         /   \ /             /   \         /   \                 C
6830 C       o    k1             o                                                  C
6831 C         (I)          (II)                (III)          (IV)                 C
6832 C                                                                              C
6833 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6834 C                                                                              C
6835 C                            Antiparallel chains                               C
6836 C                                                                              C
6837 C          o             o                   o             o                   C
6838 C         /j\           / \             \   / \           / \   /              C
6839 C        /   \         /   \             \ /   \         /   \ /               C
6840 C      j1| o |l        | o |              o| o |         | o |o                C
6841 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6842 C      \i/   \         /   \ /             /   \         /   \                 C
6843 C       o     k1            o                                                  C
6844 C         (I)          (II)                (III)          (IV)                 C
6845 C                                                                              C
6846 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6847 C                                                                              C
6848 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6849 C                                                                              C
6850 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6851 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6852 cd        eello5=0.0d0
6853 cd        return
6854 cd      endif
6855 cd      write (iout,*)
6856 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6857 cd     &   ' and',k,l
6858       itk=itortyp(itype(k))
6859       itl=itortyp(itype(l))
6860       itj=itortyp(itype(j))
6861       eello5_1=0.0d0
6862       eello5_2=0.0d0
6863       eello5_3=0.0d0
6864       eello5_4=0.0d0
6865 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6866 cd     &   eel5_3_num,eel5_4_num)
6867       do iii=1,2
6868         do kkk=1,5
6869           do lll=1,3
6870             derx(lll,kkk,iii)=0.0d0
6871           enddo
6872         enddo
6873       enddo
6874 cd      eij=facont_hb(jj,i)
6875 cd      ekl=facont_hb(kk,k)
6876 cd      ekont=eij*ekl
6877 cd      write (iout,*)'Contacts have occurred for peptide groups',
6878 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6879 cd      goto 1111
6880 C Contribution from the graph I.
6881 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6882 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6883       call transpose2(EUg(1,1,k),auxmat(1,1))
6884       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6885       vv(1)=pizda(1,1)-pizda(2,2)
6886       vv(2)=pizda(1,2)+pizda(2,1)
6887       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6888      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6889       if (calc_grad) then
6890 C Explicit gradient in virtual-dihedral angles.
6891       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6892      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6893      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6894       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6895       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6896       vv(1)=pizda(1,1)-pizda(2,2)
6897       vv(2)=pizda(1,2)+pizda(2,1)
6898       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6899      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6900      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6901       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6902       vv(1)=pizda(1,1)-pizda(2,2)
6903       vv(2)=pizda(1,2)+pizda(2,1)
6904       if (l.eq.j+1) then
6905         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6906      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6907      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6908       else
6909         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6910      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6911      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6912       endif
6913 C Cartesian gradient
6914       do iii=1,2
6915         do kkk=1,5
6916           do lll=1,3
6917             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6918      &        pizda(1,1))
6919             vv(1)=pizda(1,1)-pizda(2,2)
6920             vv(2)=pizda(1,2)+pizda(2,1)
6921             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6922      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6923      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6924           enddo
6925         enddo
6926       enddo
6927 c      goto 1112
6928       endif
6929 c1111  continue
6930 C Contribution from graph II
6931       call transpose2(EE(1,1,itk),auxmat(1,1))
6932       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6933       vv(1)=pizda(1,1)+pizda(2,2)
6934       vv(2)=pizda(2,1)-pizda(1,2)
6935       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6936      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6937       if (calc_grad) then
6938 C Explicit gradient in virtual-dihedral angles.
6939       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6940      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6941       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6942       vv(1)=pizda(1,1)+pizda(2,2)
6943       vv(2)=pizda(2,1)-pizda(1,2)
6944       if (l.eq.j+1) then
6945         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6946      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6947      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6948       else
6949         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6950      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6951      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6952       endif
6953 C Cartesian gradient
6954       do iii=1,2
6955         do kkk=1,5
6956           do lll=1,3
6957             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6958      &        pizda(1,1))
6959             vv(1)=pizda(1,1)+pizda(2,2)
6960             vv(2)=pizda(2,1)-pizda(1,2)
6961             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6962      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6963      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6964           enddo
6965         enddo
6966       enddo
6967 cd      goto 1112
6968       endif
6969 cd1111  continue
6970       if (l.eq.j+1) then
6971 cd        goto 1110
6972 C Parallel orientation
6973 C Contribution from graph III
6974         call transpose2(EUg(1,1,l),auxmat(1,1))
6975         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6976         vv(1)=pizda(1,1)-pizda(2,2)
6977         vv(2)=pizda(1,2)+pizda(2,1)
6978         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6979      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6980         if (calc_grad) then
6981 C Explicit gradient in virtual-dihedral angles.
6982         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6983      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6984      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6985         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6986         vv(1)=pizda(1,1)-pizda(2,2)
6987         vv(2)=pizda(1,2)+pizda(2,1)
6988         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6989      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6990      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6991         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6992         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6993         vv(1)=pizda(1,1)-pizda(2,2)
6994         vv(2)=pizda(1,2)+pizda(2,1)
6995         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6996      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6997      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6998 C Cartesian gradient
6999         do iii=1,2
7000           do kkk=1,5
7001             do lll=1,3
7002               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7003      &          pizda(1,1))
7004               vv(1)=pizda(1,1)-pizda(2,2)
7005               vv(2)=pizda(1,2)+pizda(2,1)
7006               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7007      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7008      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7009             enddo
7010           enddo
7011         enddo
7012 cd        goto 1112
7013         endif
7014 C Contribution from graph IV
7015 cd1110    continue
7016         call transpose2(EE(1,1,itl),auxmat(1,1))
7017         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7018         vv(1)=pizda(1,1)+pizda(2,2)
7019         vv(2)=pizda(2,1)-pizda(1,2)
7020         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7021      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7022         if (calc_grad) then
7023 C Explicit gradient in virtual-dihedral angles.
7024         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7025      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7026         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7027         vv(1)=pizda(1,1)+pizda(2,2)
7028         vv(2)=pizda(2,1)-pizda(1,2)
7029         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7030      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7031      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7032 C Cartesian gradient
7033         do iii=1,2
7034           do kkk=1,5
7035             do lll=1,3
7036               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7037      &          pizda(1,1))
7038               vv(1)=pizda(1,1)+pizda(2,2)
7039               vv(2)=pizda(2,1)-pizda(1,2)
7040               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7041      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7042      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7043             enddo
7044           enddo
7045         enddo
7046         endif
7047       else
7048 C Antiparallel orientation
7049 C Contribution from graph III
7050 c        goto 1110
7051         call transpose2(EUg(1,1,j),auxmat(1,1))
7052         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7053         vv(1)=pizda(1,1)-pizda(2,2)
7054         vv(2)=pizda(1,2)+pizda(2,1)
7055         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7056      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7057         if (calc_grad) then
7058 C Explicit gradient in virtual-dihedral angles.
7059         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7060      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7061      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7062         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7063         vv(1)=pizda(1,1)-pizda(2,2)
7064         vv(2)=pizda(1,2)+pizda(2,1)
7065         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7066      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7067      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7068         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7069         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7070         vv(1)=pizda(1,1)-pizda(2,2)
7071         vv(2)=pizda(1,2)+pizda(2,1)
7072         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7073      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7074      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7075 C Cartesian gradient
7076         do iii=1,2
7077           do kkk=1,5
7078             do lll=1,3
7079               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7080      &          pizda(1,1))
7081               vv(1)=pizda(1,1)-pizda(2,2)
7082               vv(2)=pizda(1,2)+pizda(2,1)
7083               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7084      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7085      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7086             enddo
7087           enddo
7088         enddo
7089 cd        goto 1112
7090         endif
7091 C Contribution from graph IV
7092 1110    continue
7093         call transpose2(EE(1,1,itj),auxmat(1,1))
7094         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7095         vv(1)=pizda(1,1)+pizda(2,2)
7096         vv(2)=pizda(2,1)-pizda(1,2)
7097         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7098      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7099         if (calc_grad) then
7100 C Explicit gradient in virtual-dihedral angles.
7101         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7102      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7103         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7104         vv(1)=pizda(1,1)+pizda(2,2)
7105         vv(2)=pizda(2,1)-pizda(1,2)
7106         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7107      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7108      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7109 C Cartesian gradient
7110         do iii=1,2
7111           do kkk=1,5
7112             do lll=1,3
7113               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7114      &          pizda(1,1))
7115               vv(1)=pizda(1,1)+pizda(2,2)
7116               vv(2)=pizda(2,1)-pizda(1,2)
7117               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7118      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7119      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7120             enddo
7121           enddo
7122         enddo
7123       endif
7124       endif
7125 1112  continue
7126       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7127 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7128 cd        write (2,*) 'ijkl',i,j,k,l
7129 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7130 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7131 cd      endif
7132 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7133 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7134 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7135 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7136       if (calc_grad) then
7137       if (j.lt.nres-1) then
7138         j1=j+1
7139         j2=j-1
7140       else
7141         j1=j-1
7142         j2=j-2
7143       endif
7144       if (l.lt.nres-1) then
7145         l1=l+1
7146         l2=l-1
7147       else
7148         l1=l-1
7149         l2=l-2
7150       endif
7151 cd      eij=1.0d0
7152 cd      ekl=1.0d0
7153 cd      ekont=1.0d0
7154 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7155       do ll=1,3
7156         ggg1(ll)=eel5*g_contij(ll,1)
7157         ggg2(ll)=eel5*g_contij(ll,2)
7158 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7159         ghalf=0.5d0*ggg1(ll)
7160 cd        ghalf=0.0d0
7161         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7162         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7163         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7164         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7165 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7166         ghalf=0.5d0*ggg2(ll)
7167 cd        ghalf=0.0d0
7168         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7169         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7170         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7171         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7172       enddo
7173 cd      goto 1112
7174       do m=i+1,j-1
7175         do ll=1,3
7176 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7177           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7178         enddo
7179       enddo
7180       do m=k+1,l-1
7181         do ll=1,3
7182 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7183           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7184         enddo
7185       enddo
7186 c1112  continue
7187       do m=i+2,j2
7188         do ll=1,3
7189           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7190         enddo
7191       enddo
7192       do m=k+2,l2
7193         do ll=1,3
7194           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7195         enddo
7196       enddo
7197 cd      do iii=1,nres-3
7198 cd        write (2,*) iii,g_corr5_loc(iii)
7199 cd      enddo
7200       endif
7201       eello5=ekont*eel5
7202 cd      write (2,*) 'ekont',ekont
7203 cd      write (iout,*) 'eello5',ekont*eel5
7204       return
7205       end
7206 c--------------------------------------------------------------------------
7207       double precision function eello6(i,j,k,l,jj,kk)
7208       implicit real*8 (a-h,o-z)
7209       include 'DIMENSIONS'
7210       include 'DIMENSIONS.ZSCOPT'
7211       include 'COMMON.IOUNITS'
7212       include 'COMMON.CHAIN'
7213       include 'COMMON.DERIV'
7214       include 'COMMON.INTERACT'
7215       include 'COMMON.CONTACTS'
7216       include 'COMMON.TORSION'
7217       include 'COMMON.VAR'
7218       include 'COMMON.GEO'
7219       include 'COMMON.FFIELD'
7220       double precision ggg1(3),ggg2(3)
7221 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7222 cd        eello6=0.0d0
7223 cd        return
7224 cd      endif
7225 cd      write (iout,*)
7226 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7227 cd     &   ' and',k,l
7228       eello6_1=0.0d0
7229       eello6_2=0.0d0
7230       eello6_3=0.0d0
7231       eello6_4=0.0d0
7232       eello6_5=0.0d0
7233       eello6_6=0.0d0
7234 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7235 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7236       do iii=1,2
7237         do kkk=1,5
7238           do lll=1,3
7239             derx(lll,kkk,iii)=0.0d0
7240           enddo
7241         enddo
7242       enddo
7243 cd      eij=facont_hb(jj,i)
7244 cd      ekl=facont_hb(kk,k)
7245 cd      ekont=eij*ekl
7246 cd      eij=1.0d0
7247 cd      ekl=1.0d0
7248 cd      ekont=1.0d0
7249       if (l.eq.j+1) then
7250         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7251         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7252         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7253         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7254         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7255         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7256       else
7257         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7258         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7259         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7260         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7261         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7262           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7263         else
7264           eello6_5=0.0d0
7265         endif
7266         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7267       endif
7268 C If turn contributions are considered, they will be handled separately.
7269       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7270 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7271 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7272 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7273 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7274 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7275 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7276 cd      goto 1112
7277       if (calc_grad) then
7278       if (j.lt.nres-1) then
7279         j1=j+1
7280         j2=j-1
7281       else
7282         j1=j-1
7283         j2=j-2
7284       endif
7285       if (l.lt.nres-1) then
7286         l1=l+1
7287         l2=l-1
7288       else
7289         l1=l-1
7290         l2=l-2
7291       endif
7292       do ll=1,3
7293         ggg1(ll)=eel6*g_contij(ll,1)
7294         ggg2(ll)=eel6*g_contij(ll,2)
7295 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7296         ghalf=0.5d0*ggg1(ll)
7297 cd        ghalf=0.0d0
7298         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7299         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7300         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7301         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7302         ghalf=0.5d0*ggg2(ll)
7303 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7304 cd        ghalf=0.0d0
7305         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7306         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7307         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7308         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7309       enddo
7310 cd      goto 1112
7311       do m=i+1,j-1
7312         do ll=1,3
7313 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7314           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7315         enddo
7316       enddo
7317       do m=k+1,l-1
7318         do ll=1,3
7319 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7320           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7321         enddo
7322       enddo
7323 1112  continue
7324       do m=i+2,j2
7325         do ll=1,3
7326           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7327         enddo
7328       enddo
7329       do m=k+2,l2
7330         do ll=1,3
7331           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7332         enddo
7333       enddo
7334 cd      do iii=1,nres-3
7335 cd        write (2,*) iii,g_corr6_loc(iii)
7336 cd      enddo
7337       endif
7338       eello6=ekont*eel6
7339 cd      write (2,*) 'ekont',ekont
7340 cd      write (iout,*) 'eello6',ekont*eel6
7341       return
7342       end
7343 c--------------------------------------------------------------------------
7344       double precision function eello6_graph1(i,j,k,l,imat,swap)
7345       implicit real*8 (a-h,o-z)
7346       include 'DIMENSIONS'
7347       include 'DIMENSIONS.ZSCOPT'
7348       include 'COMMON.IOUNITS'
7349       include 'COMMON.CHAIN'
7350       include 'COMMON.DERIV'
7351       include 'COMMON.INTERACT'
7352       include 'COMMON.CONTACTS'
7353       include 'COMMON.TORSION'
7354       include 'COMMON.VAR'
7355       include 'COMMON.GEO'
7356       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7357       logical swap
7358       logical lprn
7359       common /kutas/ lprn
7360 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7361 C                                                                              C
7362 C      Parallel       Antiparallel                                             C
7363 C                                                                              C
7364 C          o             o                                                     C
7365 C         /l\           /j\                                                    C
7366 C        /   \         /   \                                                   C
7367 C       /| o |         | o |\                                                  C
7368 C     \ j|/k\|  /   \  |/k\|l /                                                C
7369 C      \ /   \ /     \ /   \ /                                                 C
7370 C       o     o       o     o                                                  C
7371 C       i             i                                                        C
7372 C                                                                              C
7373 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7374       itk=itortyp(itype(k))
7375       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7376       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7377       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7378       call transpose2(EUgC(1,1,k),auxmat(1,1))
7379       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7380       vv1(1)=pizda1(1,1)-pizda1(2,2)
7381       vv1(2)=pizda1(1,2)+pizda1(2,1)
7382       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7383       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7384       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7385       s5=scalar2(vv(1),Dtobr2(1,i))
7386 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7387       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7388       if (.not. calc_grad) return
7389       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7390      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7391      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7392      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7393      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7394      & +scalar2(vv(1),Dtobr2der(1,i)))
7395       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7396       vv1(1)=pizda1(1,1)-pizda1(2,2)
7397       vv1(2)=pizda1(1,2)+pizda1(2,1)
7398       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7399       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7400       if (l.eq.j+1) then
7401         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7402      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7403      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7404      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7405      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7406       else
7407         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7408      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7409      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7410      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7411      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7412       endif
7413       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7414       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7415       vv1(1)=pizda1(1,1)-pizda1(2,2)
7416       vv1(2)=pizda1(1,2)+pizda1(2,1)
7417       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7418      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7419      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7420      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7421       do iii=1,2
7422         if (swap) then
7423           ind=3-iii
7424         else
7425           ind=iii
7426         endif
7427         do kkk=1,5
7428           do lll=1,3
7429             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7430             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7431             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7432             call transpose2(EUgC(1,1,k),auxmat(1,1))
7433             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7434      &        pizda1(1,1))
7435             vv1(1)=pizda1(1,1)-pizda1(2,2)
7436             vv1(2)=pizda1(1,2)+pizda1(2,1)
7437             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7438             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7439      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7440             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7441      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7442             s5=scalar2(vv(1),Dtobr2(1,i))
7443             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7444           enddo
7445         enddo
7446       enddo
7447       return
7448       end
7449 c----------------------------------------------------------------------------
7450       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7451       implicit real*8 (a-h,o-z)
7452       include 'DIMENSIONS'
7453       include 'DIMENSIONS.ZSCOPT'
7454       include 'COMMON.IOUNITS'
7455       include 'COMMON.CHAIN'
7456       include 'COMMON.DERIV'
7457       include 'COMMON.INTERACT'
7458       include 'COMMON.CONTACTS'
7459       include 'COMMON.TORSION'
7460       include 'COMMON.VAR'
7461       include 'COMMON.GEO'
7462       logical swap
7463       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7464      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7465       logical lprn
7466       common /kutas/ lprn
7467 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7468 C                                                                              C
7469 C      Parallel       Antiparallel                                             C
7470 C                                                                              C
7471 C          o             o                                                     C
7472 C     \   /l\           /j\   /                                                C
7473 C      \ /   \         /   \ /                                                 C
7474 C       o| o |         | o |o                                                  C
7475 C     \ j|/k\|      \  |/k\|l                                                  C
7476 C      \ /   \       \ /   \                                                   C
7477 C       o             o                                                        C
7478 C       i             i                                                        C
7479 C                                                                              C
7480 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7481 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7482 C AL 7/4/01 s1 would occur in the sixth-order moment,
7483 C           but not in a cluster cumulant
7484 #ifdef MOMENT
7485       s1=dip(1,jj,i)*dip(1,kk,k)
7486 #endif
7487       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7488       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7489       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7490       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7491       call transpose2(EUg(1,1,k),auxmat(1,1))
7492       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7493       vv(1)=pizda(1,1)-pizda(2,2)
7494       vv(2)=pizda(1,2)+pizda(2,1)
7495       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7496 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7497 #ifdef MOMENT
7498       eello6_graph2=-(s1+s2+s3+s4)
7499 #else
7500       eello6_graph2=-(s2+s3+s4)
7501 #endif
7502 c      eello6_graph2=-s3
7503       if (.not. calc_grad) return
7504 C Derivatives in gamma(i-1)
7505       if (i.gt.1) then
7506 #ifdef MOMENT
7507         s1=dipderg(1,jj,i)*dip(1,kk,k)
7508 #endif
7509         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7510         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7511         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7512         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7513 #ifdef MOMENT
7514         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7515 #else
7516         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7517 #endif
7518 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7519       endif
7520 C Derivatives in gamma(k-1)
7521 #ifdef MOMENT
7522       s1=dip(1,jj,i)*dipderg(1,kk,k)
7523 #endif
7524       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7525       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7526       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7527       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7528       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7529       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7530       vv(1)=pizda(1,1)-pizda(2,2)
7531       vv(2)=pizda(1,2)+pizda(2,1)
7532       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7533 #ifdef MOMENT
7534       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7535 #else
7536       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7537 #endif
7538 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7539 C Derivatives in gamma(j-1) or gamma(l-1)
7540       if (j.gt.1) then
7541 #ifdef MOMENT
7542         s1=dipderg(3,jj,i)*dip(1,kk,k)
7543 #endif
7544         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7545         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7546         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7547         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7548         vv(1)=pizda(1,1)-pizda(2,2)
7549         vv(2)=pizda(1,2)+pizda(2,1)
7550         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7551 #ifdef MOMENT
7552         if (swap) then
7553           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7554         else
7555           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7556         endif
7557 #endif
7558         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7559 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7560       endif
7561 C Derivatives in gamma(l-1) or gamma(j-1)
7562       if (l.gt.1) then
7563 #ifdef MOMENT
7564         s1=dip(1,jj,i)*dipderg(3,kk,k)
7565 #endif
7566         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7567         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7568         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7569         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7570         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7571         vv(1)=pizda(1,1)-pizda(2,2)
7572         vv(2)=pizda(1,2)+pizda(2,1)
7573         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7574 #ifdef MOMENT
7575         if (swap) then
7576           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7577         else
7578           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7579         endif
7580 #endif
7581         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7582 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7583       endif
7584 C Cartesian derivatives.
7585       if (lprn) then
7586         write (2,*) 'In eello6_graph2'
7587         do iii=1,2
7588           write (2,*) 'iii=',iii
7589           do kkk=1,5
7590             write (2,*) 'kkk=',kkk
7591             do jjj=1,2
7592               write (2,'(3(2f10.5),5x)')
7593      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7594             enddo
7595           enddo
7596         enddo
7597       endif
7598       do iii=1,2
7599         do kkk=1,5
7600           do lll=1,3
7601 #ifdef MOMENT
7602             if (iii.eq.1) then
7603               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7604             else
7605               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7606             endif
7607 #endif
7608             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7609      &        auxvec(1))
7610             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7611             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7612      &        auxvec(1))
7613             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7614             call transpose2(EUg(1,1,k),auxmat(1,1))
7615             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7616      &        pizda(1,1))
7617             vv(1)=pizda(1,1)-pizda(2,2)
7618             vv(2)=pizda(1,2)+pizda(2,1)
7619             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7620 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7621 #ifdef MOMENT
7622             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7623 #else
7624             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7625 #endif
7626             if (swap) then
7627               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7628             else
7629               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7630             endif
7631           enddo
7632         enddo
7633       enddo
7634       return
7635       end
7636 c----------------------------------------------------------------------------
7637       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7638       implicit real*8 (a-h,o-z)
7639       include 'DIMENSIONS'
7640       include 'DIMENSIONS.ZSCOPT'
7641       include 'COMMON.IOUNITS'
7642       include 'COMMON.CHAIN'
7643       include 'COMMON.DERIV'
7644       include 'COMMON.INTERACT'
7645       include 'COMMON.CONTACTS'
7646       include 'COMMON.TORSION'
7647       include 'COMMON.VAR'
7648       include 'COMMON.GEO'
7649       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7650       logical swap
7651 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7652 C                                                                              C
7653 C      Parallel       Antiparallel                                             C
7654 C                                                                              C
7655 C          o             o                                                     C
7656 C         /l\   /   \   /j\                                                    C
7657 C        /   \ /     \ /   \                                                   C
7658 C       /| o |o       o| o |\                                                  C
7659 C       j|/k\|  /      |/k\|l /                                                C
7660 C        /   \ /       /   \ /                                                 C
7661 C       /     o       /     o                                                  C
7662 C       i             i                                                        C
7663 C                                                                              C
7664 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7665 C
7666 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7667 C           energy moment and not to the cluster cumulant.
7668       iti=itortyp(itype(i))
7669       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7670         itj1=itortyp(itype(j+1))
7671       else
7672         itj1=ntortyp+1
7673       endif
7674       itk=itortyp(itype(k))
7675       itk1=itortyp(itype(k+1))
7676       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7677         itl1=itortyp(itype(l+1))
7678       else
7679         itl1=ntortyp+1
7680       endif
7681 #ifdef MOMENT
7682       s1=dip(4,jj,i)*dip(4,kk,k)
7683 #endif
7684       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7685       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7686       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7687       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7688       call transpose2(EE(1,1,itk),auxmat(1,1))
7689       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7690       vv(1)=pizda(1,1)+pizda(2,2)
7691       vv(2)=pizda(2,1)-pizda(1,2)
7692       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7693 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7694 #ifdef MOMENT
7695       eello6_graph3=-(s1+s2+s3+s4)
7696 #else
7697       eello6_graph3=-(s2+s3+s4)
7698 #endif
7699 c      eello6_graph3=-s4
7700       if (.not. calc_grad) return
7701 C Derivatives in gamma(k-1)
7702       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7703       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7704       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7705       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7706 C Derivatives in gamma(l-1)
7707       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7708       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7709       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7710       vv(1)=pizda(1,1)+pizda(2,2)
7711       vv(2)=pizda(2,1)-pizda(1,2)
7712       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7713       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7714 C Cartesian derivatives.
7715       do iii=1,2
7716         do kkk=1,5
7717           do lll=1,3
7718 #ifdef MOMENT
7719             if (iii.eq.1) then
7720               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7721             else
7722               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7723             endif
7724 #endif
7725             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7726      &        auxvec(1))
7727             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7728             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7729      &        auxvec(1))
7730             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7731             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7732      &        pizda(1,1))
7733             vv(1)=pizda(1,1)+pizda(2,2)
7734             vv(2)=pizda(2,1)-pizda(1,2)
7735             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7736 #ifdef MOMENT
7737             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7738 #else
7739             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7740 #endif
7741             if (swap) then
7742               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7743             else
7744               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7745             endif
7746 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7747           enddo
7748         enddo
7749       enddo
7750       return
7751       end
7752 c----------------------------------------------------------------------------
7753       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7754       implicit real*8 (a-h,o-z)
7755       include 'DIMENSIONS'
7756       include 'DIMENSIONS.ZSCOPT'
7757       include 'COMMON.IOUNITS'
7758       include 'COMMON.CHAIN'
7759       include 'COMMON.DERIV'
7760       include 'COMMON.INTERACT'
7761       include 'COMMON.CONTACTS'
7762       include 'COMMON.TORSION'
7763       include 'COMMON.VAR'
7764       include 'COMMON.GEO'
7765       include 'COMMON.FFIELD'
7766       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7767      & auxvec1(2),auxmat1(2,2)
7768       logical swap
7769 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7770 C                                                                              C
7771 C      Parallel       Antiparallel                                             C
7772 C                                                                              C
7773 C          o             o                                                     C
7774 C         /l\   /   \   /j\                                                    C
7775 C        /   \ /     \ /   \                                                   C
7776 C       /| o |o       o| o |\                                                  C
7777 C     \ j|/k\|      \  |/k\|l                                                  C
7778 C      \ /   \       \ /   \                                                   C
7779 C       o     \       o     \                                                  C
7780 C       i             i                                                        C
7781 C                                                                              C
7782 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7783 C
7784 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7785 C           energy moment and not to the cluster cumulant.
7786 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7787       iti=itortyp(itype(i))
7788       itj=itortyp(itype(j))
7789       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7790         itj1=itortyp(itype(j+1))
7791       else
7792         itj1=ntortyp+1
7793       endif
7794       itk=itortyp(itype(k))
7795       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7796         itk1=itortyp(itype(k+1))
7797       else
7798         itk1=ntortyp+1
7799       endif
7800       itl=itortyp(itype(l))
7801       if (l.lt.nres-1) then
7802         itl1=itortyp(itype(l+1))
7803       else
7804         itl1=ntortyp+1
7805       endif
7806 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7807 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7808 cd     & ' itl',itl,' itl1',itl1
7809 #ifdef MOMENT
7810       if (imat.eq.1) then
7811         s1=dip(3,jj,i)*dip(3,kk,k)
7812       else
7813         s1=dip(2,jj,j)*dip(2,kk,l)
7814       endif
7815 #endif
7816       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7817       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7818       if (j.eq.l+1) then
7819         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7820         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7821       else
7822         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7823         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7824       endif
7825       call transpose2(EUg(1,1,k),auxmat(1,1))
7826       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7827       vv(1)=pizda(1,1)-pizda(2,2)
7828       vv(2)=pizda(2,1)+pizda(1,2)
7829       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7830 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7831 #ifdef MOMENT
7832       eello6_graph4=-(s1+s2+s3+s4)
7833 #else
7834       eello6_graph4=-(s2+s3+s4)
7835 #endif
7836       if (.not. calc_grad) return
7837 C Derivatives in gamma(i-1)
7838       if (i.gt.1) then
7839 #ifdef MOMENT
7840         if (imat.eq.1) then
7841           s1=dipderg(2,jj,i)*dip(3,kk,k)
7842         else
7843           s1=dipderg(4,jj,j)*dip(2,kk,l)
7844         endif
7845 #endif
7846         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7847         if (j.eq.l+1) then
7848           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7849           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7850         else
7851           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7852           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7853         endif
7854         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7855         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7856 cd          write (2,*) 'turn6 derivatives'
7857 #ifdef MOMENT
7858           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7859 #else
7860           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7861 #endif
7862         else
7863 #ifdef MOMENT
7864           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7865 #else
7866           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7867 #endif
7868         endif
7869       endif
7870 C Derivatives in gamma(k-1)
7871 #ifdef MOMENT
7872       if (imat.eq.1) then
7873         s1=dip(3,jj,i)*dipderg(2,kk,k)
7874       else
7875         s1=dip(2,jj,j)*dipderg(4,kk,l)
7876       endif
7877 #endif
7878       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7879       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7880       if (j.eq.l+1) then
7881         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7882         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7883       else
7884         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7885         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7886       endif
7887       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7888       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7889       vv(1)=pizda(1,1)-pizda(2,2)
7890       vv(2)=pizda(2,1)+pizda(1,2)
7891       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7892       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7893 #ifdef MOMENT
7894         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7895 #else
7896         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7897 #endif
7898       else
7899 #ifdef MOMENT
7900         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7901 #else
7902         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7903 #endif
7904       endif
7905 C Derivatives in gamma(j-1) or gamma(l-1)
7906       if (l.eq.j+1 .and. l.gt.1) then
7907         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7908         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7909         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7910         vv(1)=pizda(1,1)-pizda(2,2)
7911         vv(2)=pizda(2,1)+pizda(1,2)
7912         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7913         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7914       else if (j.gt.1) then
7915         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7916         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7917         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7918         vv(1)=pizda(1,1)-pizda(2,2)
7919         vv(2)=pizda(2,1)+pizda(1,2)
7920         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7921         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7922           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7923         else
7924           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7925         endif
7926       endif
7927 C Cartesian derivatives.
7928       do iii=1,2
7929         do kkk=1,5
7930           do lll=1,3
7931 #ifdef MOMENT
7932             if (iii.eq.1) then
7933               if (imat.eq.1) then
7934                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7935               else
7936                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7937               endif
7938             else
7939               if (imat.eq.1) then
7940                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7941               else
7942                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7943               endif
7944             endif
7945 #endif
7946             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7947      &        auxvec(1))
7948             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7949             if (j.eq.l+1) then
7950               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7951      &          b1(1,itj1),auxvec(1))
7952               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7953             else
7954               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7955      &          b1(1,itl1),auxvec(1))
7956               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7957             endif
7958             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7959      &        pizda(1,1))
7960             vv(1)=pizda(1,1)-pizda(2,2)
7961             vv(2)=pizda(2,1)+pizda(1,2)
7962             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7963             if (swap) then
7964               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7965 #ifdef MOMENT
7966                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7967      &             -(s1+s2+s4)
7968 #else
7969                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7970      &             -(s2+s4)
7971 #endif
7972                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7973               else
7974 #ifdef MOMENT
7975                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7976 #else
7977                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7978 #endif
7979                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7980               endif
7981             else
7982 #ifdef MOMENT
7983               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7984 #else
7985               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7986 #endif
7987               if (l.eq.j+1) then
7988                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7989               else
7990                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7991               endif
7992             endif
7993           enddo
7994         enddo
7995       enddo
7996       return
7997       end
7998 c----------------------------------------------------------------------------
7999       double precision function eello_turn6(i,jj,kk)
8000       implicit real*8 (a-h,o-z)
8001       include 'DIMENSIONS'
8002       include 'DIMENSIONS.ZSCOPT'
8003       include 'COMMON.IOUNITS'
8004       include 'COMMON.CHAIN'
8005       include 'COMMON.DERIV'
8006       include 'COMMON.INTERACT'
8007       include 'COMMON.CONTACTS'
8008       include 'COMMON.TORSION'
8009       include 'COMMON.VAR'
8010       include 'COMMON.GEO'
8011       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8012      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8013      &  ggg1(3),ggg2(3)
8014       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8015      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8016 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8017 C           the respective energy moment and not to the cluster cumulant.
8018       eello_turn6=0.0d0
8019       j=i+4
8020       k=i+1
8021       l=i+3
8022       iti=itortyp(itype(i))
8023       itk=itortyp(itype(k))
8024       itk1=itortyp(itype(k+1))
8025       itl=itortyp(itype(l))
8026       itj=itortyp(itype(j))
8027 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8028 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8029 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8030 cd        eello6=0.0d0
8031 cd        return
8032 cd      endif
8033 cd      write (iout,*)
8034 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8035 cd     &   ' and',k,l
8036 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8037       do iii=1,2
8038         do kkk=1,5
8039           do lll=1,3
8040             derx_turn(lll,kkk,iii)=0.0d0
8041           enddo
8042         enddo
8043       enddo
8044 cd      eij=1.0d0
8045 cd      ekl=1.0d0
8046 cd      ekont=1.0d0
8047       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8048 cd      eello6_5=0.0d0
8049 cd      write (2,*) 'eello6_5',eello6_5
8050 #ifdef MOMENT
8051       call transpose2(AEA(1,1,1),auxmat(1,1))
8052       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8053       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8054       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8055 #else
8056       s1 = 0.0d0
8057 #endif
8058       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8059       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8060       s2 = scalar2(b1(1,itk),vtemp1(1))
8061 #ifdef MOMENT
8062       call transpose2(AEA(1,1,2),atemp(1,1))
8063       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8064       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8065       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8066 #else
8067       s8=0.0d0
8068 #endif
8069       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8070       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8071       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8072 #ifdef MOMENT
8073       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8074       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8075       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8076       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8077       ss13 = scalar2(b1(1,itk),vtemp4(1))
8078       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8079 #else
8080       s13=0.0d0
8081 #endif
8082 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8083 c      s1=0.0d0
8084 c      s2=0.0d0
8085 c      s8=0.0d0
8086 c      s12=0.0d0
8087 c      s13=0.0d0
8088       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8089       if (calc_grad) then
8090 C Derivatives in gamma(i+2)
8091 #ifdef MOMENT
8092       call transpose2(AEA(1,1,1),auxmatd(1,1))
8093       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8094       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8095       call transpose2(AEAderg(1,1,2),atempd(1,1))
8096       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8097       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8098 #else
8099       s8d=0.0d0
8100 #endif
8101       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8102       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8103       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8104 c      s1d=0.0d0
8105 c      s2d=0.0d0
8106 c      s8d=0.0d0
8107 c      s12d=0.0d0
8108 c      s13d=0.0d0
8109       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8110 C Derivatives in gamma(i+3)
8111 #ifdef MOMENT
8112       call transpose2(AEA(1,1,1),auxmatd(1,1))
8113       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8114       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8115       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8116 #else
8117       s1d=0.0d0
8118 #endif
8119       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8120       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8121       s2d = scalar2(b1(1,itk),vtemp1d(1))
8122 #ifdef MOMENT
8123       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8124       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8125 #endif
8126       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8127 #ifdef MOMENT
8128       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8129       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8130       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8131 #else
8132       s13d=0.0d0
8133 #endif
8134 c      s1d=0.0d0
8135 c      s2d=0.0d0
8136 c      s8d=0.0d0
8137 c      s12d=0.0d0
8138 c      s13d=0.0d0
8139 #ifdef MOMENT
8140       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8141      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8142 #else
8143       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8144      &               -0.5d0*ekont*(s2d+s12d)
8145 #endif
8146 C Derivatives in gamma(i+4)
8147       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8148       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8149       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8150 #ifdef MOMENT
8151       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8152       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8153       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8154 #else
8155       s13d = 0.0d0
8156 #endif
8157 c      s1d=0.0d0
8158 c      s2d=0.0d0
8159 c      s8d=0.0d0
8160 C      s12d=0.0d0
8161 c      s13d=0.0d0
8162 #ifdef MOMENT
8163       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8164 #else
8165       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8166 #endif
8167 C Derivatives in gamma(i+5)
8168 #ifdef MOMENT
8169       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8170       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8171       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8172 #else
8173       s1d = 0.0d0
8174 #endif
8175       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8176       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8177       s2d = scalar2(b1(1,itk),vtemp1d(1))
8178 #ifdef MOMENT
8179       call transpose2(AEA(1,1,2),atempd(1,1))
8180       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8181       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8182 #else
8183       s8d = 0.0d0
8184 #endif
8185       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8186       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8187 #ifdef MOMENT
8188       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8189       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8190       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8191 #else
8192       s13d = 0.0d0
8193 #endif
8194 c      s1d=0.0d0
8195 c      s2d=0.0d0
8196 c      s8d=0.0d0
8197 c      s12d=0.0d0
8198 c      s13d=0.0d0
8199 #ifdef MOMENT
8200       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8201      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8202 #else
8203       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8204      &               -0.5d0*ekont*(s2d+s12d)
8205 #endif
8206 C Cartesian derivatives
8207       do iii=1,2
8208         do kkk=1,5
8209           do lll=1,3
8210 #ifdef MOMENT
8211             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8212             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8213             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8214 #else
8215             s1d = 0.0d0
8216 #endif
8217             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8218             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8219      &          vtemp1d(1))
8220             s2d = scalar2(b1(1,itk),vtemp1d(1))
8221 #ifdef MOMENT
8222             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8223             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8224             s8d = -(atempd(1,1)+atempd(2,2))*
8225      &           scalar2(cc(1,1,itl),vtemp2(1))
8226 #else
8227             s8d = 0.0d0
8228 #endif
8229             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8230      &           auxmatd(1,1))
8231             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8232             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8233 c      s1d=0.0d0
8234 c      s2d=0.0d0
8235 c      s8d=0.0d0
8236 c      s12d=0.0d0
8237 c      s13d=0.0d0
8238 #ifdef MOMENT
8239             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8240      &        - 0.5d0*(s1d+s2d)
8241 #else
8242             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8243      &        - 0.5d0*s2d
8244 #endif
8245 #ifdef MOMENT
8246             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8247      &        - 0.5d0*(s8d+s12d)
8248 #else
8249             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8250      &        - 0.5d0*s12d
8251 #endif
8252           enddo
8253         enddo
8254       enddo
8255 #ifdef MOMENT
8256       do kkk=1,5
8257         do lll=1,3
8258           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8259      &      achuj_tempd(1,1))
8260           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8261           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8262           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8263           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8264           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8265      &      vtemp4d(1))
8266           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8267           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8268           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8269         enddo
8270       enddo
8271 #endif
8272 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8273 cd     &  16*eel_turn6_num
8274 cd      goto 1112
8275       if (j.lt.nres-1) then
8276         j1=j+1
8277         j2=j-1
8278       else
8279         j1=j-1
8280         j2=j-2
8281       endif
8282       if (l.lt.nres-1) then
8283         l1=l+1
8284         l2=l-1
8285       else
8286         l1=l-1
8287         l2=l-2
8288       endif
8289       do ll=1,3
8290         ggg1(ll)=eel_turn6*g_contij(ll,1)
8291         ggg2(ll)=eel_turn6*g_contij(ll,2)
8292         ghalf=0.5d0*ggg1(ll)
8293 cd        ghalf=0.0d0
8294         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8295      &    +ekont*derx_turn(ll,2,1)
8296         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8297         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8298      &    +ekont*derx_turn(ll,4,1)
8299         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8300         ghalf=0.5d0*ggg2(ll)
8301 cd        ghalf=0.0d0
8302         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8303      &    +ekont*derx_turn(ll,2,2)
8304         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8305         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8306      &    +ekont*derx_turn(ll,4,2)
8307         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8308       enddo
8309 cd      goto 1112
8310       do m=i+1,j-1
8311         do ll=1,3
8312           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8313         enddo
8314       enddo
8315       do m=k+1,l-1
8316         do ll=1,3
8317           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8318         enddo
8319       enddo
8320 1112  continue
8321       do m=i+2,j2
8322         do ll=1,3
8323           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8324         enddo
8325       enddo
8326       do m=k+2,l2
8327         do ll=1,3
8328           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8329         enddo
8330       enddo
8331 cd      do iii=1,nres-3
8332 cd        write (2,*) iii,g_corr6_loc(iii)
8333 cd      enddo
8334       endif
8335       eello_turn6=ekont*eel_turn6
8336 cd      write (2,*) 'ekont',ekont
8337 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8338       return
8339       end
8340 crc-------------------------------------------------
8341 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8342       subroutine Eliptransfer(eliptran)
8343       implicit real*8 (a-h,o-z)
8344       include 'DIMENSIONS'
8345       include 'COMMON.GEO'
8346       include 'COMMON.VAR'
8347       include 'COMMON.LOCAL'
8348       include 'COMMON.CHAIN'
8349       include 'COMMON.DERIV'
8350       include 'COMMON.INTERACT'
8351       include 'COMMON.IOUNITS'
8352       include 'COMMON.CALC'
8353       include 'COMMON.CONTROL'
8354       include 'COMMON.SPLITELE'
8355       include 'COMMON.SBRIDGE'
8356 C this is done by Adasko
8357 C      print *,"wchodze"
8358 C structure of box:
8359 C      water
8360 C--bordliptop-- buffore starts
8361 C--bufliptop--- here true lipid starts
8362 C      lipid
8363 C--buflipbot--- lipid ends buffore starts
8364 C--bordlipbot--buffore ends
8365       eliptran=0.0
8366       do i=1,nres
8367 C       do i=1,1
8368         if (itype(i).eq.ntyp1) cycle
8369
8370         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8371         if (positi.le.0) positi=positi+boxzsize
8372 C        print *,i
8373 C first for peptide groups
8374 c for each residue check if it is in lipid or lipid water border area
8375        if ((positi.gt.bordlipbot)
8376      &.and.(positi.lt.bordliptop)) then
8377 C the energy transfer exist
8378         if (positi.lt.buflipbot) then
8379 C what fraction I am in
8380          fracinbuf=1.0d0-
8381      &        ((positi-bordlipbot)/lipbufthick)
8382 C lipbufthick is thickenes of lipid buffore
8383          sslip=sscalelip(fracinbuf)
8384          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8385          eliptran=eliptran+sslip*pepliptran
8386          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8387          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8388 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8389         elseif (positi.gt.bufliptop) then
8390          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8391          sslip=sscalelip(fracinbuf)
8392          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8393          eliptran=eliptran+sslip*pepliptran
8394          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8395          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8396 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8397 C          print *, "doing sscalefor top part"
8398 C         print *,i,sslip,fracinbuf,ssgradlip
8399         else
8400          eliptran=eliptran+pepliptran
8401 C         print *,"I am in true lipid"
8402         endif
8403 C       else
8404 C       eliptran=elpitran+0.0 ! I am in water
8405        endif
8406        enddo
8407 C       print *, "nic nie bylo w lipidzie?"
8408 C now multiply all by the peptide group transfer factor
8409 C       eliptran=eliptran*pepliptran
8410 C now the same for side chains
8411 CV       do i=1,1
8412        do i=1,nres
8413         if (itype(i).eq.ntyp1) cycle
8414         positi=(mod(c(3,i+nres),boxzsize))
8415         if (positi.le.0) positi=positi+boxzsize
8416 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8417 c for each residue check if it is in lipid or lipid water border area
8418 C       respos=mod(c(3,i+nres),boxzsize)
8419 C       print *,positi,bordlipbot,buflipbot
8420        if ((positi.gt.bordlipbot)
8421      & .and.(positi.lt.bordliptop)) then
8422 C the energy transfer exist
8423         if (positi.lt.buflipbot) then
8424          fracinbuf=1.0d0-
8425      &     ((positi-bordlipbot)/lipbufthick)
8426 C lipbufthick is thickenes of lipid buffore
8427          sslip=sscalelip(fracinbuf)
8428          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8429          eliptran=eliptran+sslip*liptranene(itype(i))
8430          gliptranx(3,i)=gliptranx(3,i)
8431      &+ssgradlip*liptranene(itype(i))
8432          gliptranc(3,i-1)= gliptranc(3,i-1)
8433      &+ssgradlip*liptranene(itype(i))
8434 C         print *,"doing sccale for lower part"
8435         elseif (positi.gt.bufliptop) then
8436          fracinbuf=1.0d0-
8437      &((bordliptop-positi)/lipbufthick)
8438          sslip=sscalelip(fracinbuf)
8439          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8440          eliptran=eliptran+sslip*liptranene(itype(i))
8441          gliptranx(3,i)=gliptranx(3,i)
8442      &+ssgradlip*liptranene(itype(i))
8443          gliptranc(3,i-1)= gliptranc(3,i-1)
8444      &+ssgradlip*liptranene(itype(i))
8445 C          print *, "doing sscalefor top part",sslip,fracinbuf
8446         else
8447          eliptran=eliptran+liptranene(itype(i))
8448 C         print *,"I am in true lipid"
8449         endif
8450         endif ! if in lipid or buffor
8451 C       else
8452 C       eliptran=elpitran+0.0 ! I am in water
8453        enddo
8454        return
8455        end
8456
8457
8458 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8459
8460       SUBROUTINE MATVEC2(A1,V1,V2)
8461       implicit real*8 (a-h,o-z)
8462       include 'DIMENSIONS'
8463       DIMENSION A1(2,2),V1(2),V2(2)
8464 c      DO 1 I=1,2
8465 c        VI=0.0
8466 c        DO 3 K=1,2
8467 c    3     VI=VI+A1(I,K)*V1(K)
8468 c        Vaux(I)=VI
8469 c    1 CONTINUE
8470
8471       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8472       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8473
8474       v2(1)=vaux1
8475       v2(2)=vaux2
8476       END
8477 C---------------------------------------
8478       SUBROUTINE MATMAT2(A1,A2,A3)
8479       implicit real*8 (a-h,o-z)
8480       include 'DIMENSIONS'
8481       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8482 c      DIMENSION AI3(2,2)
8483 c        DO  J=1,2
8484 c          A3IJ=0.0
8485 c          DO K=1,2
8486 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8487 c          enddo
8488 c          A3(I,J)=A3IJ
8489 c       enddo
8490 c      enddo
8491
8492       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8493       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8494       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8495       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8496
8497       A3(1,1)=AI3_11
8498       A3(2,1)=AI3_21
8499       A3(1,2)=AI3_12
8500       A3(2,2)=AI3_22
8501       END
8502
8503 c-------------------------------------------------------------------------
8504       double precision function scalar2(u,v)
8505       implicit none
8506       double precision u(2),v(2)
8507       double precision sc
8508       integer i
8509       scalar2=u(1)*v(1)+u(2)*v(2)
8510       return
8511       end
8512
8513 C-----------------------------------------------------------------------------
8514
8515       subroutine transpose2(a,at)
8516       implicit none
8517       double precision a(2,2),at(2,2)
8518       at(1,1)=a(1,1)
8519       at(1,2)=a(2,1)
8520       at(2,1)=a(1,2)
8521       at(2,2)=a(2,2)
8522       return
8523       end
8524 c--------------------------------------------------------------------------
8525       subroutine transpose(n,a,at)
8526       implicit none
8527       integer n,i,j
8528       double precision a(n,n),at(n,n)
8529       do i=1,n
8530         do j=1,n
8531           at(j,i)=a(i,j)
8532         enddo
8533       enddo
8534       return
8535       end
8536 C---------------------------------------------------------------------------
8537       subroutine prodmat3(a1,a2,kk,transp,prod)
8538       implicit none
8539       integer i,j
8540       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8541       logical transp
8542 crc      double precision auxmat(2,2),prod_(2,2)
8543
8544       if (transp) then
8545 crc        call transpose2(kk(1,1),auxmat(1,1))
8546 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8547 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8548
8549            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8550      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8551            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8552      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8553            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8554      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8555            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8556      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8557
8558       else
8559 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8560 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8561
8562            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8563      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8564            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8565      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8566            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8567      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8568            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8569      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8570
8571       endif
8572 c      call transpose2(a2(1,1),a2t(1,1))
8573
8574 crc      print *,transp
8575 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8576 crc      print *,((prod(i,j),i=1,2),j=1,2)
8577
8578       return
8579       end
8580 C-----------------------------------------------------------------------------
8581       double precision function scalar(u,v)
8582       implicit none
8583       double precision u(3),v(3)
8584       double precision sc
8585       integer i
8586       sc=0.0d0
8587       do i=1,3
8588         sc=sc+u(i)*v(i)
8589       enddo
8590       scalar=sc
8591       return
8592       end
8593 C-----------------------------------------------------------------------
8594       double precision function sscale(r)
8595       double precision r,gamm
8596       include "COMMON.SPLITELE"
8597       if(r.lt.r_cut-rlamb) then
8598         sscale=1.0d0
8599       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8600         gamm=(r-(r_cut-rlamb))/rlamb
8601         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8602       else
8603         sscale=0d0
8604       endif
8605       return
8606       end
8607 C-----------------------------------------------------------------------
8608 C-----------------------------------------------------------------------
8609       double precision function sscagrad(r)
8610       double precision r,gamm
8611       include "COMMON.SPLITELE"
8612       if(r.lt.r_cut-rlamb) then
8613         sscagrad=0.0d0
8614       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8615         gamm=(r-(r_cut-rlamb))/rlamb
8616         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8617       else
8618         sscagrad=0.0d0
8619       endif
8620       return
8621       end
8622 C-----------------------------------------------------------------------
8623 C-----------------------------------------------------------------------
8624       double precision function sscalelip(r)
8625       double precision r,gamm
8626       include "COMMON.SPLITELE"
8627 C      if(r.lt.r_cut-rlamb) then
8628 C        sscale=1.0d0
8629 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8630 C        gamm=(r-(r_cut-rlamb))/rlamb
8631         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8632 C      else
8633 C        sscale=0d0
8634 C      endif
8635       return
8636       end
8637 C-----------------------------------------------------------------------
8638       double precision function sscagradlip(r)
8639       double precision r,gamm
8640       include "COMMON.SPLITELE"
8641 C     if(r.lt.r_cut-rlamb) then
8642 C        sscagrad=0.0d0
8643 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8644 C        gamm=(r-(r_cut-rlamb))/rlamb
8645         sscagradlip=r*(6*r-6.0d0)
8646 C      else
8647 C        sscagrad=0.0d0
8648 C      endif
8649       return
8650       end
8651
8652 C-----------------------------------------------------------------------
8653        subroutine set_shield_fac
8654       implicit real*8 (a-h,o-z)
8655       include 'DIMENSIONS'
8656       include 'COMMON.CHAIN'
8657       include 'COMMON.DERIV'
8658       include 'COMMON.IOUNITS'
8659       include 'COMMON.SHIELD'
8660       include 'COMMON.INTERACT'
8661 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8662       double precision div77_81/0.974996043d0/,
8663      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8664
8665 C the vector between center of side_chain and peptide group
8666        double precision pep_side(3),long,side_calf(3),
8667      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8668      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8669 C the line belowe needs to be changed for FGPROC>1
8670       do i=1,nres-1
8671       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8672       ishield_list(i)=0
8673 Cif there two consequtive dummy atoms there is no peptide group between them
8674 C the line below has to be changed for FGPROC>1
8675       VolumeTotal=0.0
8676       do k=1,nres
8677        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8678        dist_pep_side=0.0
8679        dist_side_calf=0.0
8680        do j=1,3
8681 C first lets set vector conecting the ithe side-chain with kth side-chain
8682       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8683 C      pep_side(j)=2.0d0
8684 C and vector conecting the side-chain with its proper calfa
8685       side_calf(j)=c(j,k+nres)-c(j,k)
8686 C      side_calf(j)=2.0d0
8687       pept_group(j)=c(j,i)-c(j,i+1)
8688 C lets have their lenght
8689       dist_pep_side=pep_side(j)**2+dist_pep_side
8690       dist_side_calf=dist_side_calf+side_calf(j)**2
8691       dist_pept_group=dist_pept_group+pept_group(j)**2
8692       enddo
8693        dist_pep_side=dsqrt(dist_pep_side)
8694        dist_pept_group=dsqrt(dist_pept_group)
8695        dist_side_calf=dsqrt(dist_side_calf)
8696       do j=1,3
8697         pep_side_norm(j)=pep_side(j)/dist_pep_side
8698         side_calf_norm(j)=dist_side_calf
8699       enddo
8700 C now sscale fraction
8701        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8702 C       print *,buff_shield,"buff"
8703 C now sscale
8704         if (sh_frac_dist.le.0.0) cycle
8705 C If we reach here it means that this side chain reaches the shielding sphere
8706 C Lets add him to the list for gradient
8707         ishield_list(i)=ishield_list(i)+1
8708 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8709 C this list is essential otherwise problem would be O3
8710         shield_list(ishield_list(i),i)=k
8711 C Lets have the sscale value
8712         if (sh_frac_dist.gt.1.0) then
8713          scale_fac_dist=1.0d0
8714          do j=1,3
8715          sh_frac_dist_grad(j)=0.0d0
8716          enddo
8717         else
8718          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8719      &                   *(2.0*sh_frac_dist-3.0d0)
8720          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8721      &                  /dist_pep_side/buff_shield*0.5
8722 C remember for the final gradient multiply sh_frac_dist_grad(j)
8723 C for side_chain by factor -2 !
8724          do j=1,3
8725          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8726 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8727 C     &                    sh_frac_dist_grad(j)
8728          enddo
8729         endif
8730 C        if ((i.eq.3).and.(k.eq.2)) then
8731 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8732 C     & ,"TU"
8733 C        endif
8734
8735 C this is what is now we have the distance scaling now volume...
8736       short=short_r_sidechain(itype(k))
8737       long=long_r_sidechain(itype(k))
8738       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8739 C now costhet_grad
8740 C       costhet=0.0d0
8741        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8742 C       costhet_fac=0.0d0
8743        do j=1,3
8744          costhet_grad(j)=costhet_fac*pep_side(j)
8745        enddo
8746 C remember for the final gradient multiply costhet_grad(j)
8747 C for side_chain by factor -2 !
8748 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8749 C pep_side0pept_group is vector multiplication
8750       pep_side0pept_group=0.0
8751       do j=1,3
8752       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8753       enddo
8754       cosalfa=(pep_side0pept_group/
8755      & (dist_pep_side*dist_side_calf))
8756       fac_alfa_sin=1.0-cosalfa**2
8757       fac_alfa_sin=dsqrt(fac_alfa_sin)
8758       rkprim=fac_alfa_sin*(long-short)+short
8759 C now costhet_grad
8760        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8761        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8762
8763        do j=1,3
8764          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8765      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8766      &*(long-short)/fac_alfa_sin*cosalfa/
8767      &((dist_pep_side*dist_side_calf))*
8768      &((side_calf(j))-cosalfa*
8769      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8770
8771         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8772      &*(long-short)/fac_alfa_sin*cosalfa
8773      &/((dist_pep_side*dist_side_calf))*
8774      &(pep_side(j)-
8775      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8776        enddo
8777
8778       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8779      &                    /VSolvSphere_div
8780      &                    *wshield
8781 C now the gradient...
8782 C grad_shield is gradient of Calfa for peptide groups
8783 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8784 C     &               costhet,cosphi
8785 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8786 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8787       do j=1,3
8788       grad_shield(j,i)=grad_shield(j,i)
8789 C gradient po skalowaniu
8790      &                +(sh_frac_dist_grad(j)
8791 C  gradient po costhet
8792      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8793      &-scale_fac_dist*(cosphi_grad_long(j))
8794      &/(1.0-cosphi) )*div77_81
8795      &*VofOverlap
8796 C grad_shield_side is Cbeta sidechain gradient
8797       grad_shield_side(j,ishield_list(i),i)=
8798      &        (sh_frac_dist_grad(j)*-2.0d0
8799      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8800      &       +scale_fac_dist*(cosphi_grad_long(j))
8801      &        *2.0d0/(1.0-cosphi))
8802      &        *div77_81*VofOverlap
8803
8804        grad_shield_loc(j,ishield_list(i),i)=
8805      &   scale_fac_dist*cosphi_grad_loc(j)
8806      &        *2.0d0/(1.0-cosphi)
8807      &        *div77_81*VofOverlap
8808       enddo
8809       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8810       enddo
8811       fac_shield(i)=VolumeTotal*div77_81+div4_81
8812 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8813       enddo
8814       return
8815       end
8816 C--------------------------------------------------------------------------
8817 C first for shielding is setting of function of side-chains
8818        subroutine set_shield_fac2
8819       implicit real*8 (a-h,o-z)
8820       include 'DIMENSIONS'
8821       include 'COMMON.CHAIN'
8822       include 'COMMON.DERIV'
8823       include 'COMMON.IOUNITS'
8824       include 'COMMON.SHIELD'
8825       include 'COMMON.INTERACT'
8826 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8827       double precision div77_81/0.974996043d0/,
8828      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8829
8830 C the vector between center of side_chain and peptide group
8831        double precision pep_side(3),long,side_calf(3),
8832      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8833      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8834 C the line belowe needs to be changed for FGPROC>1
8835       do i=1,nres-1
8836       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8837       ishield_list(i)=0
8838 Cif there two consequtive dummy atoms there is no peptide group between them
8839 C the line below has to be changed for FGPROC>1
8840       VolumeTotal=0.0
8841       do k=1,nres
8842        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8843        dist_pep_side=0.0
8844        dist_side_calf=0.0
8845        do j=1,3
8846 C first lets set vector conecting the ithe side-chain with kth side-chain
8847       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8848 C      pep_side(j)=2.0d0
8849 C and vector conecting the side-chain with its proper calfa
8850       side_calf(j)=c(j,k+nres)-c(j,k)
8851 C      side_calf(j)=2.0d0
8852       pept_group(j)=c(j,i)-c(j,i+1)
8853 C lets have their lenght
8854       dist_pep_side=pep_side(j)**2+dist_pep_side
8855       dist_side_calf=dist_side_calf+side_calf(j)**2
8856       dist_pept_group=dist_pept_group+pept_group(j)**2
8857       enddo
8858        dist_pep_side=dsqrt(dist_pep_side)
8859        dist_pept_group=dsqrt(dist_pept_group)
8860        dist_side_calf=dsqrt(dist_side_calf)
8861       do j=1,3
8862         pep_side_norm(j)=pep_side(j)/dist_pep_side
8863         side_calf_norm(j)=dist_side_calf
8864       enddo
8865 C now sscale fraction
8866        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8867 C       print *,buff_shield,"buff"
8868 C now sscale
8869         if (sh_frac_dist.le.0.0) cycle
8870 C If we reach here it means that this side chain reaches the shielding sphere
8871 C Lets add him to the list for gradient
8872         ishield_list(i)=ishield_list(i)+1
8873 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8874 C this list is essential otherwise problem would be O3
8875         shield_list(ishield_list(i),i)=k
8876 C Lets have the sscale value
8877         if (sh_frac_dist.gt.1.0) then
8878          scale_fac_dist=1.0d0
8879          do j=1,3
8880          sh_frac_dist_grad(j)=0.0d0
8881          enddo
8882         else
8883          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8884      &                   *(2.0d0*sh_frac_dist-3.0d0)
8885          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8886      &                  /dist_pep_side/buff_shield*0.5d0
8887 C remember for the final gradient multiply sh_frac_dist_grad(j)
8888 C for side_chain by factor -2 !
8889          do j=1,3
8890          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8891 C         sh_frac_dist_grad(j)=0.0d0
8892 C         scale_fac_dist=1.0d0
8893 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8894 C     &                    sh_frac_dist_grad(j)
8895          enddo
8896         endif
8897 C this is what is now we have the distance scaling now volume...
8898       short=short_r_sidechain(itype(k))
8899       long=long_r_sidechain(itype(k))
8900       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8901       sinthet=short/dist_pep_side*costhet
8902 C now costhet_grad
8903 C       costhet=0.6d0
8904 C       sinthet=0.8
8905        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8906 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8907 C     &             -short/dist_pep_side**2/costhet)
8908 C       costhet_fac=0.0d0
8909        do j=1,3
8910          costhet_grad(j)=costhet_fac*pep_side(j)
8911        enddo
8912 C remember for the final gradient multiply costhet_grad(j)
8913 C for side_chain by factor -2 !
8914 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8915 C pep_side0pept_group is vector multiplication
8916       pep_side0pept_group=0.0d0
8917       do j=1,3
8918       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8919       enddo
8920       cosalfa=(pep_side0pept_group/
8921      & (dist_pep_side*dist_side_calf))
8922       fac_alfa_sin=1.0d0-cosalfa**2
8923       fac_alfa_sin=dsqrt(fac_alfa_sin)
8924       rkprim=fac_alfa_sin*(long-short)+short
8925 C      rkprim=short
8926
8927 C now costhet_grad
8928        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8929 C       cosphi=0.6
8930        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8931        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8932      &      dist_pep_side**2)
8933 C       sinphi=0.8
8934        do j=1,3
8935          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8936      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8937      &*(long-short)/fac_alfa_sin*cosalfa/
8938      &((dist_pep_side*dist_side_calf))*
8939      &((side_calf(j))-cosalfa*
8940      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8941 C       cosphi_grad_long(j)=0.0d0
8942         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8943      &*(long-short)/fac_alfa_sin*cosalfa
8944      &/((dist_pep_side*dist_side_calf))*
8945      &(pep_side(j)-
8946      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8947 C       cosphi_grad_loc(j)=0.0d0
8948        enddo
8949 C      print *,sinphi,sinthet
8950       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
8951      &                    /VSolvSphere_div
8952 C     &                    *wshield
8953 C now the gradient...
8954       do j=1,3
8955       grad_shield(j,i)=grad_shield(j,i)
8956 C gradient po skalowaniu
8957      &                +(sh_frac_dist_grad(j)*VofOverlap
8958 C  gradient po costhet
8959      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
8960      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8961      &       sinphi/sinthet*costhet*costhet_grad(j)
8962      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8963      & )*wshield
8964 C grad_shield_side is Cbeta sidechain gradient
8965       grad_shield_side(j,ishield_list(i),i)=
8966      &        (sh_frac_dist_grad(j)*-2.0d0
8967      &        *VofOverlap
8968      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8969      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8970      &       sinphi/sinthet*costhet*costhet_grad(j)
8971      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8972      &       )*wshield
8973
8974        grad_shield_loc(j,ishield_list(i),i)=
8975      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8976      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
8977      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
8978      &        ))
8979      &        *wshield
8980       enddo
8981       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8982       enddo
8983       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
8984 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8985 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
8986       enddo
8987       return
8988       end
8989