source/wham/src-M/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.SHIELD'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C      write(iout,*) 'po elektostatyce'
  50 C
  51 C Calculate electrostatic (H-bonding) energy of the main chain.
  52 C
  53   106 continue
  54       if (shield_mode.eq.1) then
  55        call set_shield_fac
  56       else if  (shield_mode.eq.2) then
  57        call set_shield_fac2
  58       endif
  59       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  60 C            write(iout,*) 'po eelec'
  61
  62 C Calculate excluded-volume interaction energy between peptide groups
  63 C and side chains.
  64 C
  65       call escp(evdw2,evdw2_14)
  66 c
  67 c Calculate the bond-stretching energy
  68 c
  69
  70       call ebond(estr)
  71 C       write (iout,*) "estr",estr
  72 C
  73 C Calculate the disulfide-bridge and other energy and the contributions
  74 C from other distance constraints.
  75 cd    print *,'Calling EHPB'
  76       call edis(ehpb)
  77 cd    print *,'EHPB exitted succesfully.'
  78 C
  79 C Calculate the virtual-bond-angle energy.
  80 C
  81 C      print *,'Bend energy finished.'
  82       call ebend(ebe,ethetacnstr)
  83 cd    print *,'Bend energy finished.'
  84 C
  85 C Calculate the SC local energy.
  86 C
  87       call esc(escloc)
  88 C       print *,'SCLOC energy finished.'
  89 C
  90 C Calculate the virtual-bond torsional energy.
  91 C
  92 cd    print *,'nterm=',nterm
  93       call etor(etors,edihcnstr,fact(1))
  94 C
  95 C 6/23/01 Calculate double-torsional energy
  96 C
  97       call etor_d(etors_d,fact(2))
  98 C
  99 C 21/5/07 Calculate local sicdechain correlation energy
 100 C
 101       call eback_sc_corr(esccor)
 102
 103       if (wliptran.gt.0) then
 104         call Eliptransfer(eliptran)
 105       endif
 106
 107 C
 108 C 12/1/95 Multi-body terms
 109 C
 110       n_corr=0
 111       n_corr1=0
 112       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 113      &    .or. wturn6.gt.0.0d0) then
 114 c         print *,"calling multibody_eello"
 115          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 116 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 117 c         print *,ecorr,ecorr5,ecorr6,eturn6
 118       else
 119          ecorr=0.0d0
 120          ecorr5=0.0d0
 121          ecorr6=0.0d0
 122          eturn6=0.0d0
 123       endif
 124       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 125          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 126       endif
 127 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 128 #ifdef SPLITELE
 129       if (shield_mode.gt.0) then
 130       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 131      & +welec*fact(1)*ees
 132      & +fact(1)*wvdwpp*evdw1
 133      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 134      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 135      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 136      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 137      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 138      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 139      & +wliptran*eliptran
 140       else
 141       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 142      & +wvdwpp*evdw1
 143      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 144      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 145      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 146      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 147      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 148      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 149      & +wliptran*eliptran
 150       endif
 151 #else
 152       if (shield_mode.gt.0) then
 153       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 154      & +welec*fact(1)*(ees+evdw1)
 155      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 156      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 157      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 158      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 159      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 160      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 161      & +wliptran*eliptran
 162       else
 163       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 164      & +welec*fact(1)*(ees+evdw1)
 165      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 166      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 167      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 168      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 169      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 170      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 171      & +wliptran*eliptran
 172       endif
 173 #endif
 174       energia(0)=etot
 175       energia(1)=evdw
 176 #ifdef SCP14
 177       energia(2)=evdw2-evdw2_14
 178       energia(17)=evdw2_14
 179 #else
 180       energia(2)=evdw2
 181       energia(17)=0.0d0
 182 #endif
 183 #ifdef SPLITELE
 184       energia(3)=ees
 185       energia(16)=evdw1
 186 #else
 187       energia(3)=ees+evdw1
 188       energia(16)=0.0d0
 189 #endif
 190       energia(4)=ecorr
 191       energia(5)=ecorr5
 192       energia(6)=ecorr6
 193       energia(7)=eel_loc
 194       energia(8)=eello_turn3
 195       energia(9)=eello_turn4
 196       energia(10)=eturn6
 197       energia(11)=ebe
 198       energia(12)=escloc
 199       energia(13)=etors
 200       energia(14)=etors_d
 201       energia(15)=ehpb
 202       energia(18)=estr
 203       energia(19)=esccor
 204       energia(20)=edihcnstr
 205       energia(21)=evdw_t
 206       energia(24)=ethetacnstr
 207       energia(22)=eliptran
 208 c detecting NaNQ
 209 #ifdef ISNAN
 210 #ifdef AIX
 211       if (isnan(etot).ne.0) energia(0)=1.0d+99
 212 #else
 213       if (isnan(etot)) energia(0)=1.0d+99
 214 #endif
 215 #else
 216       i=0
 217 #ifdef WINPGI
 218       idumm=proc_proc(etot,i)
 219 #else
 220       call proc_proc(etot,i)
 221 #endif
 222       if(i.eq.1)energia(0)=1.0d+99
 223 #endif
 224 #ifdef MPL
 225 c     endif
 226 #endif
 227 #define DEBUG
 228 #ifdef DEBUG
 229       call enerprint(energia,fact)
 230 #endif
 231 #undef DEBUG
 232       if (calc_grad) then
 233 C
 234 C Sum up the components of the Cartesian gradient.
 235 C
 236 #ifdef SPLITELE
 237       do i=1,nct
 238         do j=1,3
 239       if (shield_mode.eq.0) then
 240           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 241      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 242      &                wbond*gradb(j,i)+
 243      &                wstrain*ghpbc(j,i)+
 244      &                wcorr*fact(3)*gradcorr(j,i)+
 245      &                wel_loc*fact(2)*gel_loc(j,i)+
 246      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 247      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 248      &                wcorr5*fact(4)*gradcorr5(j,i)+
 249      &                wcorr6*fact(5)*gradcorr6(j,i)+
 250      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 251      &                wsccor*fact(2)*gsccorc(j,i)
 252      &               +wliptran*gliptranc(j,i)
 253           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 254      &                  wbond*gradbx(j,i)+
 255      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 256      &                  wsccor*fact(2)*gsccorx(j,i)
 257      &                 +wliptran*gliptranx(j,i)
 258         else
 259           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 260      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 261      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 262      &                wbond*gradb(j,i)+
 263      &                wstrain*ghpbc(j,i)+
 264      &                wcorr*fact(3)*gradcorr(j,i)+
 265      &                wel_loc*fact(2)*gel_loc(j,i)+
 266      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 267      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 268      &                wcorr5*fact(4)*gradcorr5(j,i)+
 269      &                wcorr6*fact(5)*gradcorr6(j,i)+
 270      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 271      &                wsccor*fact(2)*gsccorc(j,i)
 272      &               +wliptran*gliptranc(j,i)
 273      &                 +welec*gshieldc(j,i)
 274      &                 +welec*gshieldc_loc(j,i)
 275      &                 +wcorr*gshieldc_ec(j,i)
 276      &                 +wcorr*gshieldc_loc_ec(j,i)
 277      &                 +wturn3*gshieldc_t3(j,i)
 278      &                 +wturn3*gshieldc_loc_t3(j,i)
 279      &                 +wturn4*gshieldc_t4(j,i)
 280      &                 +wturn4*gshieldc_loc_t4(j,i)
 281      &                 +wel_loc*gshieldc_ll(j,i)
 282      &                 +wel_loc*gshieldc_loc_ll(j,i)
 283
 284           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 285      &                 +fact(1)*wscp*gradx_scp(j,i)+
 286      &                  wbond*gradbx(j,i)+
 287      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 288      &                  wsccor*fact(2)*gsccorx(j,i)
 289      &                 +wliptran*gliptranx(j,i)
 290      &                 +welec*gshieldx(j,i)
 291      &                 +wcorr*gshieldx_ec(j,i)
 292      &                 +wturn3*gshieldx_t3(j,i)
 293      &                 +wturn4*gshieldx_t4(j,i)
 294      &                 +wel_loc*gshieldx_ll(j,i)
 295
 296
 297         endif
 298         enddo
 299 #else
 300       do i=1,nct
 301         do j=1,3
 302                 if (shield_mode.eq.0) then
 303           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 304      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 305      &                wbond*gradb(j,i)+
 306      &                wcorr*fact(3)*gradcorr(j,i)+
 307      &                wel_loc*fact(2)*gel_loc(j,i)+
 308      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 309      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 310      &                wcorr5*fact(4)*gradcorr5(j,i)+
 311      &                wcorr6*fact(5)*gradcorr6(j,i)+
 312      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 313      &                wsccor*fact(2)*gsccorc(j,i)
 314      &               +wliptran*gliptranc(j,i)
 315           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 316      &                  wbond*gradbx(j,i)+
 317      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 318      &                  wsccor*fact(1)*gsccorx(j,i)
 319      &                 +wliptran*gliptranx(j,i)
 320               else
 321           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 322      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 323      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 324      &                wbond*gradb(j,i)+
 325      &                wcorr*fact(3)*gradcorr(j,i)+
 326      &                wel_loc*fact(2)*gel_loc(j,i)+
 327      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 328      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 329      &                wcorr5*fact(4)*gradcorr5(j,i)+
 330      &                wcorr6*fact(5)*gradcorr6(j,i)+
 331      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 332      &                wsccor*fact(2)*gsccorc(j,i)
 333      &               +wliptran*gliptranc(j,i)
 334      &                 +welec*gshieldc(j,i)
 335      &                 +welec*gshieldc_loc(j,i)
 336      &                 +wcorr*gshieldc_ec(j,i)
 337      &                 +wcorr*gshieldc_loc_ec(j,i)
 338      &                 +wturn3*gshieldc_t3(j,i)
 339      &                 +wturn3*gshieldc_loc_t3(j,i)
 340      &                 +wturn4*gshieldc_t4(j,i)
 341      &                 +wturn4*gshieldc_loc_t4(j,i)
 342      &                 +wel_loc*gshieldc_ll(j,i)
 343      &                 +wel_loc*gshieldc_loc_ll(j,i)
 344
 345           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 346      &                  fact(1)*wscp*gradx_scp(j,i)+
 347      &                  wbond*gradbx(j,i)+
 348      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 349      &                  wsccor*fact(1)*gsccorx(j,i)
 350      &                 +wliptran*gliptranx(j,i)
 351      &                 +welec*gshieldx(j,i)
 352      &                 +wcorr*gshieldx_ec(j,i)
 353      &                 +wturn3*gshieldx_t3(j,i)
 354      &                 +wturn4*gshieldx_t4(j,i)
 355      &                 +wel_loc*gshieldx_ll(j,i)
 356
 357          endif
 358         enddo
 359 #endif
 360       enddo
 361
 362
 363       do i=1,nres-3
 364         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 365      &   +wcorr5*fact(4)*g_corr5_loc(i)
 366      &   +wcorr6*fact(5)*g_corr6_loc(i)
 367      &   +wturn4*fact(3)*gel_loc_turn4(i)
 368      &   +wturn3*fact(2)*gel_loc_turn3(i)
 369      &   +wturn6*fact(5)*gel_loc_turn6(i)
 370      &   +wel_loc*fact(2)*gel_loc_loc(i)
 371 c     &   +wsccor*fact(1)*gsccor_loc(i)
 372 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 373       enddo
 374       endif
 375       if (dyn_ss) call dyn_set_nss
 376       return
 377       end
 378 C------------------------------------------------------------------------
 379       subroutine enerprint(energia,fact)
 380       implicit real*8 (a-h,o-z)
 381       include 'DIMENSIONS'
 382       include 'DIMENSIONS.ZSCOPT'
 383       include 'COMMON.IOUNITS'
 384       include 'COMMON.FFIELD'
 385       include 'COMMON.SBRIDGE'
 386       double precision energia(0:max_ene),fact(6)
 387       etot=energia(0)
 388       evdw=energia(1)+fact(6)*energia(21)
 389 #ifdef SCP14
 390       evdw2=energia(2)+energia(17)
 391 #else
 392       evdw2=energia(2)
 393 #endif
 394       ees=energia(3)
 395 #ifdef SPLITELE
 396       evdw1=energia(16)
 397 #endif
 398       ecorr=energia(4)
 399       ecorr5=energia(5)
 400       ecorr6=energia(6)
 401       eel_loc=energia(7)
 402       eello_turn3=energia(8)
 403       eello_turn4=energia(9)
 404       eello_turn6=energia(10)
 405       ebe=energia(11)
 406       escloc=energia(12)
 407       etors=energia(13)
 408       etors_d=energia(14)
 409       ehpb=energia(15)
 410       esccor=energia(19)
 411       edihcnstr=energia(20)
 412       estr=energia(18)
 413       ethetacnstr=energia(24)
 414       eliptran=energia(22)
 415 #ifdef SPLITELE
 416       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 417      &  wvdwpp,
 418      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 419      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 420      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 421      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 422      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 423      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 424      & eliptran,wliptran,etot
 425    10 format (/'Virtual-chain energies:'//
 426      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 427      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 428      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 429      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 430      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 431      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 432      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 433      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 434      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 435      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 436      & ' (SS bridges & dist. cnstr.)'/
 437      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 438      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 439      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 440      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 441      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 442      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 443      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 444      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 445      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 446      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 447      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 448      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 449      & 'ETOT=  ',1pE16.6,' (total)')
 450 #else
 451       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 452      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 453      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 454      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 455      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 456      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 457      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 458    10 format (/'Virtual-chain energies:'//
 459      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 460      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 461      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 462      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 463      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 464      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 465      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 466      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 467      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 468      & ' (SS bridges & dist. cnstr.)'/
 469      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 470      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 471      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 472      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 473      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 474      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 475      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 476      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 477      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 478      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 479      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 480      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 481      & 'ETOT=  ',1pE16.6,' (total)')
 482 #endif
 483       return
 484       end
 485 C-----------------------------------------------------------------------
 486       subroutine elj(evdw,evdw_t)
 487 C
 488 C This subroutine calculates the interaction energy of nonbonded side chains
 489 C assuming the LJ potential of interaction.
 490 C
 491       implicit real*8 (a-h,o-z)
 492       include 'DIMENSIONS'
 493       include 'DIMENSIONS.ZSCOPT'
 494       include "DIMENSIONS.COMPAR"
 495       parameter (accur=1.0d-10)
 496       include 'COMMON.GEO'
 497       include 'COMMON.VAR'
 498       include 'COMMON.LOCAL'
 499       include 'COMMON.CHAIN'
 500       include 'COMMON.DERIV'
 501       include 'COMMON.INTERACT'
 502       include 'COMMON.TORSION'
 503       include 'COMMON.ENEPS'
 504       include 'COMMON.SBRIDGE'
 505       include 'COMMON.NAMES'
 506       include 'COMMON.IOUNITS'
 507       include 'COMMON.CONTACTS'
 508       dimension gg(3)
 509       integer icant
 510       external icant
 511 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 512 c ROZNICA z cluster
 513       do i=1,210
 514         do j=1,2
 515           eneps_temp(j,i)=0.0d0
 516         enddo
 517       enddo
 518 cROZNICA
 519
 520       evdw=0.0D0
 521       evdw_t=0.0d0
 522       do i=iatsc_s,iatsc_e
 523         itypi=iabs(itype(i))
 524         if (itypi.eq.ntyp1) cycle
 525         itypi1=iabs(itype(i+1))
 526         xi=c(1,nres+i)
 527         yi=c(2,nres+i)
 528         zi=c(3,nres+i)
 529 C Change 12/1/95
 530         num_conti=0
 531 C
 532 C Calculate SC interaction energy.
 533 C
 534         do iint=1,nint_gr(i)
 535 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 536 cd   &                  'iend=',iend(i,iint)
 537           do j=istart(i,iint),iend(i,iint)
 538             itypj=iabs(itype(j))
 539             if (itypj.eq.ntyp1) cycle
 540             xj=c(1,nres+j)-xi
 541             yj=c(2,nres+j)-yi
 542             zj=c(3,nres+j)-zi
 543 C Change 12/1/95 to calculate four-body interactions
 544             rij=xj*xj+yj*yj+zj*zj
 545             rrij=1.0D0/rij
 546 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 547             eps0ij=eps(itypi,itypj)
 548             fac=rrij**expon2
 549             e1=fac*fac*aa
 550             e2=fac*bb
 551             evdwij=e1+e2
 552             ij=icant(itypi,itypj)
 553 c ROZNICA z cluster
 554             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 555             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 556 c
 557
 558 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 559 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 560 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 561 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 562 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 563 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 564             if (bb.gt.0.0d0) then
 565               evdw=evdw+evdwij
 566             else
 567               evdw_t=evdw_t+evdwij
 568             endif
 569             if (calc_grad) then
 570 C
 571 C Calculate the components of the gradient in DC and X
 572 C
 573             fac=-rrij*(e1+evdwij)
 574             gg(1)=xj*fac
 575             gg(2)=yj*fac
 576             gg(3)=zj*fac
 577             do k=1,3
 578               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 579               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 580             enddo
 581             do k=i,j-1
 582               do l=1,3
 583                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 584               enddo
 585             enddo
 586             endif
 587 C
 588 C 12/1/95, revised on 5/20/97
 589 C
 590 C Calculate the contact function. The ith column of the array JCONT will
 591 C contain the numbers of atoms that make contacts with the atom I (of numbers
 592 C greater than I). The arrays FACONT and GACONT will contain the values of
 593 C the contact function and its derivative.
 594 C
 595 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 596 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 597 C Uncomment next line, if the correlation interactions are contact function only
 598             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 599               rij=dsqrt(rij)
 600               sigij=sigma(itypi,itypj)
 601               r0ij=rs0(itypi,itypj)
 602 C
 603 C Check whether the SC's are not too far to make a contact.
 604 C
 605               rcut=1.5d0*r0ij
 606               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 607 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 608 C
 609               if (fcont.gt.0.0D0) then
 610 C If the SC-SC distance if close to sigma, apply spline.
 611 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 612 cAdam &             fcont1,fprimcont1)
 613 cAdam           fcont1=1.0d0-fcont1
 614 cAdam           if (fcont1.gt.0.0d0) then
 615 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 616 cAdam             fcont=fcont*fcont1
 617 cAdam           endif
 618 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 619 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 620 cga             do k=1,3
 621 cga               gg(k)=gg(k)*eps0ij
 622 cga             enddo
 623 cga             eps0ij=-evdwij*eps0ij
 624 C Uncomment for AL's type of SC correlation interactions.
 625 cadam           eps0ij=-evdwij
 626                 num_conti=num_conti+1
 627                 jcont(num_conti,i)=j
 628                 facont(num_conti,i)=fcont*eps0ij
 629                 fprimcont=eps0ij*fprimcont/rij
 630                 fcont=expon*fcont
 631 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 632 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 633 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 634 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 635                 gacont(1,num_conti,i)=-fprimcont*xj
 636                 gacont(2,num_conti,i)=-fprimcont*yj
 637                 gacont(3,num_conti,i)=-fprimcont*zj
 638 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 639 cd              write (iout,'(2i3,3f10.5)')
 640 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 641               endif
 642             endif
 643           enddo      ! j
 644         enddo        ! iint
 645 C Change 12/1/95
 646         num_cont(i)=num_conti
 647       enddo          ! i
 648       if (calc_grad) then
 649       do i=1,nct
 650         do j=1,3
 651           gvdwc(j,i)=expon*gvdwc(j,i)
 652           gvdwx(j,i)=expon*gvdwx(j,i)
 653         enddo
 654       enddo
 655       endif
 656 C******************************************************************************
 657 C
 658 C                              N O T E !!!
 659 C
 660 C To save time, the factor of EXPON has been extracted from ALL components
 661 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 662 C use!
 663 C
 664 C******************************************************************************
 665       return
 666       end
 667 C-----------------------------------------------------------------------------
 668       subroutine eljk(evdw,evdw_t)
 669 C
 670 C This subroutine calculates the interaction energy of nonbonded side chains
 671 C assuming the LJK potential of interaction.
 672 C
 673       implicit real*8 (a-h,o-z)
 674       include 'DIMENSIONS'
 675       include 'DIMENSIONS.ZSCOPT'
 676       include "DIMENSIONS.COMPAR"
 677       include 'COMMON.GEO'
 678       include 'COMMON.VAR'
 679       include 'COMMON.LOCAL'
 680       include 'COMMON.CHAIN'
 681       include 'COMMON.DERIV'
 682       include 'COMMON.INTERACT'
 683       include 'COMMON.ENEPS'
 684       include 'COMMON.IOUNITS'
 685       include 'COMMON.NAMES'
 686       dimension gg(3)
 687       logical scheck
 688       integer icant
 689       external icant
 690 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 691       do i=1,210
 692         do j=1,2
 693           eneps_temp(j,i)=0.0d0
 694         enddo
 695       enddo
 696       evdw=0.0D0
 697       evdw_t=0.0d0
 698       do i=iatsc_s,iatsc_e
 699         itypi=iabs(itype(i))
 700         if (itypi.eq.ntyp1) cycle
 701         itypi1=iabs(itype(i+1))
 702         xi=c(1,nres+i)
 703         yi=c(2,nres+i)
 704         zi=c(3,nres+i)
 705 C
 706 C Calculate SC interaction energy.
 707 C
 708         do iint=1,nint_gr(i)
 709           do j=istart(i,iint),iend(i,iint)
 710             itypj=iabs(itype(j))
 711             if (itypj.eq.ntyp1) cycle
 712             xj=c(1,nres+j)-xi
 713             yj=c(2,nres+j)-yi
 714             zj=c(3,nres+j)-zi
 715             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 716             fac_augm=rrij**expon
 717             e_augm=augm(itypi,itypj)*fac_augm
 718             r_inv_ij=dsqrt(rrij)
 719             rij=1.0D0/r_inv_ij
 720             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 721             fac=r_shift_inv**expon
 722             e1=fac*fac*aa
 723             e2=fac*bb
 724             evdwij=e_augm+e1+e2
 725             ij=icant(itypi,itypj)
 726             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 727      &        /dabs(eps(itypi,itypj))
 728             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 729 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 730 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 731 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 732 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 733 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 734 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 735 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 736             if (bb.gt.0.0d0) then
 737               evdw=evdw+evdwij
 738             else
 739               evdw_t=evdw_t+evdwij
 740             endif
 741             if (calc_grad) then
 742 C
 743 C Calculate the components of the gradient in DC and X
 744 C
 745             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 746             gg(1)=xj*fac
 747             gg(2)=yj*fac
 748             gg(3)=zj*fac
 749             do k=1,3
 750               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 751               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 752             enddo
 753             do k=i,j-1
 754               do l=1,3
 755                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 756               enddo
 757             enddo
 758             endif
 759           enddo      ! j
 760         enddo        ! iint
 761       enddo          ! i
 762       if (calc_grad) then
 763       do i=1,nct
 764         do j=1,3
 765           gvdwc(j,i)=expon*gvdwc(j,i)
 766           gvdwx(j,i)=expon*gvdwx(j,i)
 767         enddo
 768       enddo
 769       endif
 770       return
 771       end
 772 C-----------------------------------------------------------------------------
 773       subroutine ebp(evdw,evdw_t)
 774 C
 775 C This subroutine calculates the interaction energy of nonbonded side chains
 776 C assuming the Berne-Pechukas potential of interaction.
 777 C
 778       implicit real*8 (a-h,o-z)
 779       include 'DIMENSIONS'
 780       include 'DIMENSIONS.ZSCOPT'
 781       include "DIMENSIONS.COMPAR"
 782       include 'COMMON.GEO'
 783       include 'COMMON.VAR'
 784       include 'COMMON.LOCAL'
 785       include 'COMMON.CHAIN'
 786       include 'COMMON.DERIV'
 787       include 'COMMON.NAMES'
 788       include 'COMMON.INTERACT'
 789       include 'COMMON.ENEPS'
 790       include 'COMMON.IOUNITS'
 791       include 'COMMON.CALC'
 792       common /srutu/ icall
 793 c     double precision rrsave(maxdim)
 794       logical lprn
 795       integer icant
 796       external icant
 797       do i=1,210
 798         do j=1,2
 799           eneps_temp(j,i)=0.0d0
 800         enddo
 801       enddo
 802       evdw=0.0D0
 803       evdw_t=0.0d0
 804 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 805 c     if (icall.eq.0) then
 806 c       lprn=.true.
 807 c     else
 808         lprn=.false.
 809 c     endif
 810       ind=0
 811       do i=iatsc_s,iatsc_e
 812         itypi=iabs(itype(i))
 813         if (itypi.eq.ntyp1) cycle
 814         itypi1=iabs(itype(i+1))
 815         xi=c(1,nres+i)
 816         yi=c(2,nres+i)
 817         zi=c(3,nres+i)
 818         dxi=dc_norm(1,nres+i)
 819         dyi=dc_norm(2,nres+i)
 820         dzi=dc_norm(3,nres+i)
 821         dsci_inv=vbld_inv(i+nres)
 822 C
 823 C Calculate SC interaction energy.
 824 C
 825         do iint=1,nint_gr(i)
 826           do j=istart(i,iint),iend(i,iint)
 827             ind=ind+1
 828             itypj=iabs(itype(j))
 829             if (itypj.eq.ntyp1) cycle
 830             dscj_inv=vbld_inv(j+nres)
 831             chi1=chi(itypi,itypj)
 832             chi2=chi(itypj,itypi)
 833             chi12=chi1*chi2
 834             chip1=chip(itypi)
 835             chip2=chip(itypj)
 836             chip12=chip1*chip2
 837             alf1=alp(itypi)
 838             alf2=alp(itypj)
 839             alf12=0.5D0*(alf1+alf2)
 840 C For diagnostics only!!!
 841 c           chi1=0.0D0
 842 c           chi2=0.0D0
 843 c           chi12=0.0D0
 844 c           chip1=0.0D0
 845 c           chip2=0.0D0
 846 c           chip12=0.0D0
 847 c           alf1=0.0D0
 848 c           alf2=0.0D0
 849 c           alf12=0.0D0
 850             xj=c(1,nres+j)-xi
 851             yj=c(2,nres+j)-yi
 852             zj=c(3,nres+j)-zi
 853             dxj=dc_norm(1,nres+j)
 854             dyj=dc_norm(2,nres+j)
 855             dzj=dc_norm(3,nres+j)
 856             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 857 cd          if (icall.eq.0) then
 858 cd            rrsave(ind)=rrij
 859 cd          else
 860 cd            rrij=rrsave(ind)
 861 cd          endif
 862             rij=dsqrt(rrij)
 863 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 864             call sc_angular
 865 C Calculate whole angle-dependent part of epsilon and contributions
 866 C to its derivatives
 867             fac=(rrij*sigsq)**expon2
 868             e1=fac*fac*aa
 869             e2=fac*bb
 870             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 871             eps2der=evdwij*eps3rt
 872             eps3der=evdwij*eps2rt
 873             evdwij=evdwij*eps2rt*eps3rt
 874             ij=icant(itypi,itypj)
 875             aux=eps1*eps2rt**2*eps3rt**2
 876             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 877      &        /dabs(eps(itypi,itypj))
 878             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 879             if (bb.gt.0.0d0) then
 880               evdw=evdw+evdwij
 881             else
 882               evdw_t=evdw_t+evdwij
 883             endif
 884             if (calc_grad) then
 885             if (lprn) then
 886             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 887             epsi=bb**2/aa
 888             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 889      &        restyp(itypi),i,restyp(itypj),j,
 890      &        epsi,sigm,chi1,chi2,chip1,chip2,
 891      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 892      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 893      &        evdwij
 894             endif
 895 C Calculate gradient components.
 896             e1=e1*eps1*eps2rt**2*eps3rt**2
 897             fac=-expon*(e1+evdwij)
 898             sigder=fac/sigsq
 899             fac=rrij*fac
 900 C Calculate radial part of the gradient
 901             gg(1)=xj*fac
 902             gg(2)=yj*fac
 903             gg(3)=zj*fac
 904 C Calculate the angular part of the gradient and sum add the contributions
 905 C to the appropriate components of the Cartesian gradient.
 906             call sc_grad
 907             endif
 908           enddo      ! j
 909         enddo        ! iint
 910       enddo          ! i
 911 c     stop
 912       return
 913       end
 914 C-----------------------------------------------------------------------------
 915       subroutine egb(evdw,evdw_t)
 916 C
 917 C This subroutine calculates the interaction energy of nonbonded side chains
 918 C assuming the Gay-Berne potential of interaction.
 919 C
 920       implicit real*8 (a-h,o-z)
 921       include 'DIMENSIONS'
 922       include 'DIMENSIONS.ZSCOPT'
 923       include "DIMENSIONS.COMPAR"
 924       include 'COMMON.GEO'
 925       include 'COMMON.VAR'
 926       include 'COMMON.LOCAL'
 927       include 'COMMON.CHAIN'
 928       include 'COMMON.DERIV'
 929       include 'COMMON.NAMES'
 930       include 'COMMON.INTERACT'
 931       include 'COMMON.ENEPS'
 932       include 'COMMON.IOUNITS'
 933       include 'COMMON.CALC'
 934       include 'COMMON.SBRIDGE'
 935       logical lprn
 936       common /srutu/icall
 937       integer icant,xshift,yshift,zshift
 938       external icant
 939       do i=1,210
 940         do j=1,2
 941           eneps_temp(j,i)=0.0d0
 942         enddo
 943       enddo
 944 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 945       evdw=0.0D0
 946       evdw_t=0.0d0
 947       lprn=.false.
 948 c      if (icall.gt.0) lprn=.true.
 949       ind=0
 950       do i=iatsc_s,iatsc_e
 951         itypi=iabs(itype(i))
 952         if (itypi.eq.ntyp1) cycle
 953         itypi1=iabs(itype(i+1))
 954         xi=c(1,nres+i)
 955         yi=c(2,nres+i)
 956         zi=c(3,nres+i)
 957 C returning the ith atom to box
 958           xi=mod(xi,boxxsize)
 959           if (xi.lt.0) xi=xi+boxxsize
 960           yi=mod(yi,boxysize)
 961           if (yi.lt.0) yi=yi+boxysize
 962           zi=mod(zi,boxzsize)
 963           if (zi.lt.0) zi=zi+boxzsize
 964        if ((zi.gt.bordlipbot)
 965      &.and.(zi.lt.bordliptop)) then
 966 C the energy transfer exist
 967         if (zi.lt.buflipbot) then
 968 C what fraction I am in
 969          fracinbuf=1.0d0-
 970      &        ((zi-bordlipbot)/lipbufthick)
 971 C lipbufthick is thickenes of lipid buffore
 972          sslipi=sscalelip(fracinbuf)
 973          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 974         elseif (zi.gt.bufliptop) then
 975          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 976          sslipi=sscalelip(fracinbuf)
 977          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 978         else
 979          sslipi=1.0d0
 980          ssgradlipi=0.0
 981         endif
 982        else
 983          sslipi=0.0d0
 984          ssgradlipi=0.0
 985        endif
 986
 987         dxi=dc_norm(1,nres+i)
 988         dyi=dc_norm(2,nres+i)
 989         dzi=dc_norm(3,nres+i)
 990         dsci_inv=vbld_inv(i+nres)
 991 C
 992 C Calculate SC interaction energy.
 993 C
 994         do iint=1,nint_gr(i)
 995           do j=istart(i,iint),iend(i,iint)
 996             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 997               call dyn_ssbond_ene(i,j,evdwij)
 998               evdw=evdw+evdwij
 999 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1000 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1001 C triple bond artifac removal
1002              do k=j+1,iend(i,iint)
1003 C search over all next residues
1004               if (dyn_ss_mask(k)) then
1005 C check if they are cysteins
1006 C              write(iout,*) 'k=',k
1007               call triple_ssbond_ene(i,j,k,evdwij)
1008 C call the energy function that removes the artifical triple disulfide
1009 C bond the soubroutine is located in ssMD.F
1010               evdw=evdw+evdwij
1011 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1012 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1013               endif!dyn_ss_mask(k)
1014              enddo! k
1015             ELSE
1016             ind=ind+1
1017             itypj=iabs(itype(j))
1018             if (itypj.eq.ntyp1) cycle
1019             dscj_inv=vbld_inv(j+nres)
1020             sig0ij=sigma(itypi,itypj)
1021             chi1=chi(itypi,itypj)
1022             chi2=chi(itypj,itypi)
1023             chi12=chi1*chi2
1024             chip1=chip(itypi)
1025             chip2=chip(itypj)
1026             chip12=chip1*chip2
1027             alf1=alp(itypi)
1028             alf2=alp(itypj)
1029             alf12=0.5D0*(alf1+alf2)
1030 C For diagnostics only!!!
1031 c           chi1=0.0D0
1032 c           chi2=0.0D0
1033 c           chi12=0.0D0
1034 c           chip1=0.0D0
1035 c           chip2=0.0D0
1036 c           chip12=0.0D0
1037 c           alf1=0.0D0
1038 c           alf2=0.0D0
1039 c           alf12=0.0D0
1040             xj=c(1,nres+j)
1041             yj=c(2,nres+j)
1042             zj=c(3,nres+j)
1043 C returning jth atom to box
1044           xj=mod(xj,boxxsize)
1045           if (xj.lt.0) xj=xj+boxxsize
1046           yj=mod(yj,boxysize)
1047           if (yj.lt.0) yj=yj+boxysize
1048           zj=mod(zj,boxzsize)
1049           if (zj.lt.0) zj=zj+boxzsize
1050        if ((zj.gt.bordlipbot)
1051      &.and.(zj.lt.bordliptop)) then
1052 C the energy transfer exist
1053         if (zj.lt.buflipbot) then
1054 C what fraction I am in
1055          fracinbuf=1.0d0-
1056      &        ((zj-bordlipbot)/lipbufthick)
1057 C lipbufthick is thickenes of lipid buffore
1058          sslipj=sscalelip(fracinbuf)
1059          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1060         elseif (zj.gt.bufliptop) then
1061          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1062          sslipj=sscalelip(fracinbuf)
1063          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1064         else
1065          sslipj=1.0d0
1066          ssgradlipj=0.0
1067         endif
1068        else
1069          sslipj=0.0d0
1070          ssgradlipj=0.0
1071        endif
1072       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1073      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1074       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1075      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1076 C       if (aa.ne.aa_aq(itypi,itypj)) then
1077
1078 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1079 C     & bb_aq(itypi,itypj)-bb,
1080 C     & sslipi,sslipj
1081 C         endif
1082
1083 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1084 C checking the distance
1085       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1086       xj_safe=xj
1087       yj_safe=yj
1088       zj_safe=zj
1089       subchap=0
1090 C finding the closest
1091       do xshift=-1,1
1092       do yshift=-1,1
1093       do zshift=-1,1
1094           xj=xj_safe+xshift*boxxsize
1095           yj=yj_safe+yshift*boxysize
1096           zj=zj_safe+zshift*boxzsize
1097           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1098           if(dist_temp.lt.dist_init) then
1099             dist_init=dist_temp
1100             xj_temp=xj
1101             yj_temp=yj
1102             zj_temp=zj
1103             subchap=1
1104           endif
1105        enddo
1106        enddo
1107        enddo
1108        if (subchap.eq.1) then
1109           xj=xj_temp-xi
1110           yj=yj_temp-yi
1111           zj=zj_temp-zi
1112        else
1113           xj=xj_safe-xi
1114           yj=yj_safe-yi
1115           zj=zj_safe-zi
1116        endif
1117
1118             dxj=dc_norm(1,nres+j)
1119             dyj=dc_norm(2,nres+j)
1120             dzj=dc_norm(3,nres+j)
1121 c            write (iout,*) i,j,xj,yj,zj
1122             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1123             rij=dsqrt(rrij)
1124             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1125             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1126             if (sss.le.0.0) cycle
1127 C Calculate angle-dependent terms of energy and contributions to their
1128 C derivatives.
1129
1130             call sc_angular
1131             sigsq=1.0D0/sigsq
1132             sig=sig0ij*dsqrt(sigsq)
1133             rij_shift=1.0D0/rij-sig+sig0ij
1134 C I hate to put IF's in the loops, but here don't have another choice!!!!
1135             if (rij_shift.le.0.0D0) then
1136               evdw=1.0D20
1137               return
1138             endif
1139             sigder=-sig*sigsq
1140 c---------------------------------------------------------------
1141             rij_shift=1.0D0/rij_shift
1142             fac=rij_shift**expon
1143             e1=fac*fac*aa
1144             e2=fac*bb
1145             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1146             eps2der=evdwij*eps3rt
1147             eps3der=evdwij*eps2rt
1148             evdwij=evdwij*eps2rt*eps3rt
1149             if (bb.gt.0) then
1150               evdw=evdw+evdwij*sss
1151             else
1152               evdw_t=evdw_t+evdwij*sss
1153             endif
1154             ij=icant(itypi,itypj)
1155             aux=eps1*eps2rt**2*eps3rt**2
1156             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1157      &        /dabs(eps(itypi,itypj))
1158             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1159 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1160 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1161 c     &         aux*e2/eps(itypi,itypj)
1162 c            if (lprn) then
1163             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1164             epsi=bb**2/aa
1165 C#define DEBUG
1166 #ifdef DEBUG
1167             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1168      &        restyp(itypi),i,restyp(itypj),j,
1169      &        epsi,sigm,chi1,chi2,chip1,chip2,
1170      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1171      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1172      &        evdwij
1173              write (iout,*) "partial sum", evdw, evdw_t
1174 #endif
1175 C#undef DEBUG
1176 c            endif
1177             if (calc_grad) then
1178 C Calculate gradient components.
1179             e1=e1*eps1*eps2rt**2*eps3rt**2
1180             fac=-expon*(e1+evdwij)*rij_shift
1181             sigder=fac*sigder
1182             fac=rij*fac
1183             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1184 C Calculate the radial part of the gradient
1185             gg(1)=xj*fac
1186             gg(2)=yj*fac
1187             gg(3)=zj*fac
1188 C Calculate angular part of the gradient.
1189             call sc_grad
1190             endif
1191 C            write(iout,*)  "partial sum", evdw, evdw_t
1192             ENDIF    ! dyn_ss
1193           enddo      ! j
1194         enddo        ! iint
1195       enddo          ! i
1196       return
1197       end
1198 C-----------------------------------------------------------------------------
1199       subroutine egbv(evdw,evdw_t)
1200 C
1201 C This subroutine calculates the interaction energy of nonbonded side chains
1202 C assuming the Gay-Berne-Vorobjev potential of interaction.
1203 C
1204       implicit real*8 (a-h,o-z)
1205       include 'DIMENSIONS'
1206       include 'DIMENSIONS.ZSCOPT'
1207       include "DIMENSIONS.COMPAR"
1208       include 'COMMON.GEO'
1209       include 'COMMON.VAR'
1210       include 'COMMON.LOCAL'
1211       include 'COMMON.CHAIN'
1212       include 'COMMON.DERIV'
1213       include 'COMMON.NAMES'
1214       include 'COMMON.INTERACT'
1215       include 'COMMON.ENEPS'
1216       include 'COMMON.IOUNITS'
1217       include 'COMMON.CALC'
1218       common /srutu/ icall
1219       logical lprn
1220       integer icant
1221       external icant
1222       do i=1,210
1223         do j=1,2
1224           eneps_temp(j,i)=0.0d0
1225         enddo
1226       enddo
1227       evdw=0.0D0
1228       evdw_t=0.0d0
1229 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1230       evdw=0.0D0
1231       lprn=.false.
1232 c      if (icall.gt.0) lprn=.true.
1233       ind=0
1234       do i=iatsc_s,iatsc_e
1235         itypi=iabs(itype(i))
1236         if (itypi.eq.ntyp1) cycle
1237         itypi1=iabs(itype(i+1))
1238         xi=c(1,nres+i)
1239         yi=c(2,nres+i)
1240         zi=c(3,nres+i)
1241         dxi=dc_norm(1,nres+i)
1242         dyi=dc_norm(2,nres+i)
1243         dzi=dc_norm(3,nres+i)
1244         dsci_inv=vbld_inv(i+nres)
1245 C
1246 C Calculate SC interaction energy.
1247 C
1248         do iint=1,nint_gr(i)
1249           do j=istart(i,iint),iend(i,iint)
1250             ind=ind+1
1251             itypj=iabs(itype(j))
1252             if (itypj.eq.ntyp1) cycle
1253             dscj_inv=vbld_inv(j+nres)
1254             sig0ij=sigma(itypi,itypj)
1255             r0ij=r0(itypi,itypj)
1256             chi1=chi(itypi,itypj)
1257             chi2=chi(itypj,itypi)
1258             chi12=chi1*chi2
1259             chip1=chip(itypi)
1260             chip2=chip(itypj)
1261             chip12=chip1*chip2
1262             alf1=alp(itypi)
1263             alf2=alp(itypj)
1264             alf12=0.5D0*(alf1+alf2)
1265 C For diagnostics only!!!
1266 c           chi1=0.0D0
1267 c           chi2=0.0D0
1268 c           chi12=0.0D0
1269 c           chip1=0.0D0
1270 c           chip2=0.0D0
1271 c           chip12=0.0D0
1272 c           alf1=0.0D0
1273 c           alf2=0.0D0
1274 c           alf12=0.0D0
1275             xj=c(1,nres+j)-xi
1276             yj=c(2,nres+j)-yi
1277             zj=c(3,nres+j)-zi
1278             dxj=dc_norm(1,nres+j)
1279             dyj=dc_norm(2,nres+j)
1280             dzj=dc_norm(3,nres+j)
1281             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1282             rij=dsqrt(rrij)
1283 C Calculate angle-dependent terms of energy and contributions to their
1284 C derivatives.
1285             call sc_angular
1286             sigsq=1.0D0/sigsq
1287             sig=sig0ij*dsqrt(sigsq)
1288             rij_shift=1.0D0/rij-sig+r0ij
1289 C I hate to put IF's in the loops, but here don't have another choice!!!!
1290             if (rij_shift.le.0.0D0) then
1291               evdw=1.0D20
1292               return
1293             endif
1294             sigder=-sig*sigsq
1295 c---------------------------------------------------------------
1296             rij_shift=1.0D0/rij_shift
1297             fac=rij_shift**expon
1298             e1=fac*fac*aa
1299             e2=fac*bb
1300             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1301             eps2der=evdwij*eps3rt
1302             eps3der=evdwij*eps2rt
1303             fac_augm=rrij**expon
1304             e_augm=augm(itypi,itypj)*fac_augm
1305             evdwij=evdwij*eps2rt*eps3rt
1306             if (bb.gt.0.0d0) then
1307               evdw=evdw+evdwij+e_augm
1308             else
1309               evdw_t=evdw_t+evdwij+e_augm
1310             endif
1311             ij=icant(itypi,itypj)
1312             aux=eps1*eps2rt**2*eps3rt**2
1313             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1314      &        /dabs(eps(itypi,itypj))
1315             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1316 c            eneps_temp(ij)=eneps_temp(ij)
1317 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1318 c            if (lprn) then
1319 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1320 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1321 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1322 c     &        restyp(itypi),i,restyp(itypj),j,
1323 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1324 c     &        chi1,chi2,chip1,chip2,
1325 c     &        eps1,eps2rt**2,eps3rt**2,
1326 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1327 c     &        evdwij+e_augm
1328 c            endif
1329             if (calc_grad) then
1330 C Calculate gradient components.
1331             e1=e1*eps1*eps2rt**2*eps3rt**2
1332             fac=-expon*(e1+evdwij)*rij_shift
1333             sigder=fac*sigder
1334             fac=rij*fac-2*expon*rrij*e_augm
1335 C Calculate the radial part of the gradient
1336             gg(1)=xj*fac
1337             gg(2)=yj*fac
1338             gg(3)=zj*fac
1339 C Calculate angular part of the gradient.
1340             call sc_grad
1341             endif
1342           enddo      ! j
1343         enddo        ! iint
1344       enddo          ! i
1345       return
1346       end
1347 C-----------------------------------------------------------------------------
1348       subroutine sc_angular
1349 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1350 C om12. Called by ebp, egb, and egbv.
1351       implicit none
1352       include 'COMMON.CALC'
1353       erij(1)=xj*rij
1354       erij(2)=yj*rij
1355       erij(3)=zj*rij
1356       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1357       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1358       om12=dxi*dxj+dyi*dyj+dzi*dzj
1359       chiom12=chi12*om12
1360 C Calculate eps1(om12) and its derivative in om12
1361       faceps1=1.0D0-om12*chiom12
1362       faceps1_inv=1.0D0/faceps1
1363       eps1=dsqrt(faceps1_inv)
1364 C Following variable is eps1*deps1/dom12
1365       eps1_om12=faceps1_inv*chiom12
1366 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1367 C and om12.
1368       om1om2=om1*om2
1369       chiom1=chi1*om1
1370       chiom2=chi2*om2
1371       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1372       sigsq=1.0D0-facsig*faceps1_inv
1373       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1374       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1375       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1376 C Calculate eps2 and its derivatives in om1, om2, and om12.
1377       chipom1=chip1*om1
1378       chipom2=chip2*om2
1379       chipom12=chip12*om12
1380       facp=1.0D0-om12*chipom12
1381       facp_inv=1.0D0/facp
1382       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1383 C Following variable is the square root of eps2
1384       eps2rt=1.0D0-facp1*facp_inv
1385 C Following three variables are the derivatives of the square root of eps
1386 C in om1, om2, and om12.
1387       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1388       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1389       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1390 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1391       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1392 C Calculate whole angle-dependent part of epsilon and contributions
1393 C to its derivatives
1394       return
1395       end
1396 C----------------------------------------------------------------------------
1397       subroutine sc_grad
1398       implicit real*8 (a-h,o-z)
1399       include 'DIMENSIONS'
1400       include 'DIMENSIONS.ZSCOPT'
1401       include 'COMMON.CHAIN'
1402       include 'COMMON.DERIV'
1403       include 'COMMON.CALC'
1404       double precision dcosom1(3),dcosom2(3)
1405       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1406       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1407       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1408      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1409       do k=1,3
1410         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1411         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1412       enddo
1413       do k=1,3
1414         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1415       enddo
1416       do k=1,3
1417         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1418      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1419      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1420         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1421      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1422      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1423       enddo
1424 C
1425 C Calculate the components of the gradient in DC and X
1426 C
1427       do k=i,j-1
1428         do l=1,3
1429           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1430         enddo
1431       enddo
1432       return
1433       end
1434 c------------------------------------------------------------------------------
1435       subroutine vec_and_deriv
1436       implicit real*8 (a-h,o-z)
1437       include 'DIMENSIONS'
1438       include 'DIMENSIONS.ZSCOPT'
1439       include 'COMMON.IOUNITS'
1440       include 'COMMON.GEO'
1441       include 'COMMON.VAR'
1442       include 'COMMON.LOCAL'
1443       include 'COMMON.CHAIN'
1444       include 'COMMON.VECTORS'
1445       include 'COMMON.DERIV'
1446       include 'COMMON.INTERACT'
1447       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1448 C Compute the local reference systems. For reference system (i), the
1449 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1450 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1451       do i=1,nres-1
1452 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1453           if (i.eq.nres-1) then
1454 C Case of the last full residue
1455 C Compute the Z-axis
1456             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1457             costh=dcos(pi-theta(nres))
1458             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1459             do k=1,3
1460               uz(k,i)=fac*uz(k,i)
1461             enddo
1462             if (calc_grad) then
1463 C Compute the derivatives of uz
1464             uzder(1,1,1)= 0.0d0
1465             uzder(2,1,1)=-dc_norm(3,i-1)
1466             uzder(3,1,1)= dc_norm(2,i-1)
1467             uzder(1,2,1)= dc_norm(3,i-1)
1468             uzder(2,2,1)= 0.0d0
1469             uzder(3,2,1)=-dc_norm(1,i-1)
1470             uzder(1,3,1)=-dc_norm(2,i-1)
1471             uzder(2,3,1)= dc_norm(1,i-1)
1472             uzder(3,3,1)= 0.0d0
1473             uzder(1,1,2)= 0.0d0
1474             uzder(2,1,2)= dc_norm(3,i)
1475             uzder(3,1,2)=-dc_norm(2,i)
1476             uzder(1,2,2)=-dc_norm(3,i)
1477             uzder(2,2,2)= 0.0d0
1478             uzder(3,2,2)= dc_norm(1,i)
1479             uzder(1,3,2)= dc_norm(2,i)
1480             uzder(2,3,2)=-dc_norm(1,i)
1481             uzder(3,3,2)= 0.0d0
1482             endif
1483 C Compute the Y-axis
1484             facy=fac
1485             do k=1,3
1486               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1487             enddo
1488             if (calc_grad) then
1489 C Compute the derivatives of uy
1490             do j=1,3
1491               do k=1,3
1492                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1493      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1494                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1495               enddo
1496               uyder(j,j,1)=uyder(j,j,1)-costh
1497               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1498             enddo
1499             do j=1,2
1500               do k=1,3
1501                 do l=1,3
1502                   uygrad(l,k,j,i)=uyder(l,k,j)
1503                   uzgrad(l,k,j,i)=uzder(l,k,j)
1504                 enddo
1505               enddo
1506             enddo
1507             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1508             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1509             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1510             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1511             endif
1512           else
1513 C Other residues
1514 C Compute the Z-axis
1515             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1516             costh=dcos(pi-theta(i+2))
1517             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1518             do k=1,3
1519               uz(k,i)=fac*uz(k,i)
1520             enddo
1521             if (calc_grad) then
1522 C Compute the derivatives of uz
1523             uzder(1,1,1)= 0.0d0
1524             uzder(2,1,1)=-dc_norm(3,i+1)
1525             uzder(3,1,1)= dc_norm(2,i+1)
1526             uzder(1,2,1)= dc_norm(3,i+1)
1527             uzder(2,2,1)= 0.0d0
1528             uzder(3,2,1)=-dc_norm(1,i+1)
1529             uzder(1,3,1)=-dc_norm(2,i+1)
1530             uzder(2,3,1)= dc_norm(1,i+1)
1531             uzder(3,3,1)= 0.0d0
1532             uzder(1,1,2)= 0.0d0
1533             uzder(2,1,2)= dc_norm(3,i)
1534             uzder(3,1,2)=-dc_norm(2,i)
1535             uzder(1,2,2)=-dc_norm(3,i)
1536             uzder(2,2,2)= 0.0d0
1537             uzder(3,2,2)= dc_norm(1,i)
1538             uzder(1,3,2)= dc_norm(2,i)
1539             uzder(2,3,2)=-dc_norm(1,i)
1540             uzder(3,3,2)= 0.0d0
1541             endif
1542 C Compute the Y-axis
1543             facy=fac
1544             do k=1,3
1545               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1546             enddo
1547             if (calc_grad) then
1548 C Compute the derivatives of uy
1549             do j=1,3
1550               do k=1,3
1551                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1552      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1553                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1554               enddo
1555               uyder(j,j,1)=uyder(j,j,1)-costh
1556               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1557             enddo
1558             do j=1,2
1559               do k=1,3
1560                 do l=1,3
1561                   uygrad(l,k,j,i)=uyder(l,k,j)
1562                   uzgrad(l,k,j,i)=uzder(l,k,j)
1563                 enddo
1564               enddo
1565             enddo
1566             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1567             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1568             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1569             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1570           endif
1571           endif
1572       enddo
1573       if (calc_grad) then
1574       do i=1,nres-1
1575         vbld_inv_temp(1)=vbld_inv(i+1)
1576         if (i.lt.nres-1) then
1577           vbld_inv_temp(2)=vbld_inv(i+2)
1578         else
1579           vbld_inv_temp(2)=vbld_inv(i)
1580         endif
1581         do j=1,2
1582           do k=1,3
1583             do l=1,3
1584               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1585               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1586             enddo
1587           enddo
1588         enddo
1589       enddo
1590       endif
1591       return
1592       end
1593 C-----------------------------------------------------------------------------
1594       subroutine vec_and_deriv_test
1595       implicit real*8 (a-h,o-z)
1596       include 'DIMENSIONS'
1597       include 'DIMENSIONS.ZSCOPT'
1598       include 'COMMON.IOUNITS'
1599       include 'COMMON.GEO'
1600       include 'COMMON.VAR'
1601       include 'COMMON.LOCAL'
1602       include 'COMMON.CHAIN'
1603       include 'COMMON.VECTORS'
1604       dimension uyder(3,3,2),uzder(3,3,2)
1605 C Compute the local reference systems. For reference system (i), the
1606 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1607 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1608       do i=1,nres-1
1609           if (i.eq.nres-1) then
1610 C Case of the last full residue
1611 C Compute the Z-axis
1612             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1613             costh=dcos(pi-theta(nres))
1614             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1615 c            write (iout,*) 'fac',fac,
1616 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1617             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1618             do k=1,3
1619               uz(k,i)=fac*uz(k,i)
1620             enddo
1621 C Compute the derivatives of uz
1622             uzder(1,1,1)= 0.0d0
1623             uzder(2,1,1)=-dc_norm(3,i-1)
1624             uzder(3,1,1)= dc_norm(2,i-1)
1625             uzder(1,2,1)= dc_norm(3,i-1)
1626             uzder(2,2,1)= 0.0d0
1627             uzder(3,2,1)=-dc_norm(1,i-1)
1628             uzder(1,3,1)=-dc_norm(2,i-1)
1629             uzder(2,3,1)= dc_norm(1,i-1)
1630             uzder(3,3,1)= 0.0d0
1631             uzder(1,1,2)= 0.0d0
1632             uzder(2,1,2)= dc_norm(3,i)
1633             uzder(3,1,2)=-dc_norm(2,i)
1634             uzder(1,2,2)=-dc_norm(3,i)
1635             uzder(2,2,2)= 0.0d0
1636             uzder(3,2,2)= dc_norm(1,i)
1637             uzder(1,3,2)= dc_norm(2,i)
1638             uzder(2,3,2)=-dc_norm(1,i)
1639             uzder(3,3,2)= 0.0d0
1640 C Compute the Y-axis
1641             do k=1,3
1642               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1643             enddo
1644             facy=fac
1645             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1646      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1647      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1648             do k=1,3
1649 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1650               uy(k,i)=
1651 c     &        facy*(
1652      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1653      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1654 c     &        )
1655             enddo
1656 c            write (iout,*) 'facy',facy,
1657 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1658             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1659             do k=1,3
1660               uy(k,i)=facy*uy(k,i)
1661             enddo
1662 C Compute the derivatives of uy
1663             do j=1,3
1664               do k=1,3
1665                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1666      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1667                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1668               enddo
1669 c              uyder(j,j,1)=uyder(j,j,1)-costh
1670 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1671               uyder(j,j,1)=uyder(j,j,1)
1672      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1673               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1674      &          +uyder(j,j,2)
1675             enddo
1676             do j=1,2
1677               do k=1,3
1678                 do l=1,3
1679                   uygrad(l,k,j,i)=uyder(l,k,j)
1680                   uzgrad(l,k,j,i)=uzder(l,k,j)
1681                 enddo
1682               enddo
1683             enddo
1684             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1685             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1686             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1687             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1688           else
1689 C Other residues
1690 C Compute the Z-axis
1691             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1692             costh=dcos(pi-theta(i+2))
1693             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1694             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1695             do k=1,3
1696               uz(k,i)=fac*uz(k,i)
1697             enddo
1698 C Compute the derivatives of uz
1699             uzder(1,1,1)= 0.0d0
1700             uzder(2,1,1)=-dc_norm(3,i+1)
1701             uzder(3,1,1)= dc_norm(2,i+1)
1702             uzder(1,2,1)= dc_norm(3,i+1)
1703             uzder(2,2,1)= 0.0d0
1704             uzder(3,2,1)=-dc_norm(1,i+1)
1705             uzder(1,3,1)=-dc_norm(2,i+1)
1706             uzder(2,3,1)= dc_norm(1,i+1)
1707             uzder(3,3,1)= 0.0d0
1708             uzder(1,1,2)= 0.0d0
1709             uzder(2,1,2)= dc_norm(3,i)
1710             uzder(3,1,2)=-dc_norm(2,i)
1711             uzder(1,2,2)=-dc_norm(3,i)
1712             uzder(2,2,2)= 0.0d0
1713             uzder(3,2,2)= dc_norm(1,i)
1714             uzder(1,3,2)= dc_norm(2,i)
1715             uzder(2,3,2)=-dc_norm(1,i)
1716             uzder(3,3,2)= 0.0d0
1717 C Compute the Y-axis
1718             facy=fac
1719             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1720      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1721      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1722             do k=1,3
1723 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1724               uy(k,i)=
1725 c     &        facy*(
1726      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1727      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1728 c     &        )
1729             enddo
1730 c            write (iout,*) 'facy',facy,
1731 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1732             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1733             do k=1,3
1734               uy(k,i)=facy*uy(k,i)
1735             enddo
1736 C Compute the derivatives of uy
1737             do j=1,3
1738               do k=1,3
1739                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1740      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1741                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1742               enddo
1743 c              uyder(j,j,1)=uyder(j,j,1)-costh
1744 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1745               uyder(j,j,1)=uyder(j,j,1)
1746      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1747               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1748      &          +uyder(j,j,2)
1749             enddo
1750             do j=1,2
1751               do k=1,3
1752                 do l=1,3
1753                   uygrad(l,k,j,i)=uyder(l,k,j)
1754                   uzgrad(l,k,j,i)=uzder(l,k,j)
1755                 enddo
1756               enddo
1757             enddo
1758             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1759             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1760             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1761             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1762           endif
1763       enddo
1764       do i=1,nres-1
1765         do j=1,2
1766           do k=1,3
1767             do l=1,3
1768               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1769               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1770             enddo
1771           enddo
1772         enddo
1773       enddo
1774       return
1775       end
1776 C-----------------------------------------------------------------------------
1777       subroutine check_vecgrad
1778       implicit real*8 (a-h,o-z)
1779       include 'DIMENSIONS'
1780       include 'DIMENSIONS.ZSCOPT'
1781       include 'COMMON.IOUNITS'
1782       include 'COMMON.GEO'
1783       include 'COMMON.VAR'
1784       include 'COMMON.LOCAL'
1785       include 'COMMON.CHAIN'
1786       include 'COMMON.VECTORS'
1787       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1788       dimension uyt(3,maxres),uzt(3,maxres)
1789       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1790       double precision delta /1.0d-7/
1791       call vec_and_deriv
1792 cd      do i=1,nres
1793 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1794 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1795 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1796 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1797 cd     &     (dc_norm(if90,i),if90=1,3)
1798 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1799 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1800 cd          write(iout,'(a)')
1801 cd      enddo
1802       do i=1,nres
1803         do j=1,2
1804           do k=1,3
1805             do l=1,3
1806               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1807               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1808             enddo
1809           enddo
1810         enddo
1811       enddo
1812       call vec_and_deriv
1813       do i=1,nres
1814         do j=1,3
1815           uyt(j,i)=uy(j,i)
1816           uzt(j,i)=uz(j,i)
1817         enddo
1818       enddo
1819       do i=1,nres
1820 cd        write (iout,*) 'i=',i
1821         do k=1,3
1822           erij(k)=dc_norm(k,i)
1823         enddo
1824         do j=1,3
1825           do k=1,3
1826             dc_norm(k,i)=erij(k)
1827           enddo
1828           dc_norm(j,i)=dc_norm(j,i)+delta
1829 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1830 c          do k=1,3
1831 c            dc_norm(k,i)=dc_norm(k,i)/fac
1832 c          enddo
1833 c          write (iout,*) (dc_norm(k,i),k=1,3)
1834 c          write (iout,*) (erij(k),k=1,3)
1835           call vec_and_deriv
1836           do k=1,3
1837             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1838             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1839             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1840             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1841           enddo
1842 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1843 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1844 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1845         enddo
1846         do k=1,3
1847           dc_norm(k,i)=erij(k)
1848         enddo
1849 cd        do k=1,3
1850 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1851 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1852 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1853 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1854 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1855 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1856 cd          write (iout,'(a)')
1857 cd        enddo
1858       enddo
1859       return
1860       end
1861 C--------------------------------------------------------------------------
1862       subroutine set_matrices
1863       implicit real*8 (a-h,o-z)
1864       include 'DIMENSIONS'
1865       include 'DIMENSIONS.ZSCOPT'
1866       include 'COMMON.IOUNITS'
1867       include 'COMMON.GEO'
1868       include 'COMMON.VAR'
1869       include 'COMMON.LOCAL'
1870       include 'COMMON.CHAIN'
1871       include 'COMMON.DERIV'
1872       include 'COMMON.INTERACT'
1873       include 'COMMON.CONTACTS'
1874       include 'COMMON.TORSION'
1875       include 'COMMON.VECTORS'
1876       include 'COMMON.FFIELD'
1877       double precision auxvec(2),auxmat(2,2)
1878 C
1879 C Compute the virtual-bond-torsional-angle dependent quantities needed
1880 C to calculate the el-loc multibody terms of various order.
1881 C
1882       do i=3,nres+1
1883         if (i .lt. nres+1) then
1884           sin1=dsin(phi(i))
1885           cos1=dcos(phi(i))
1886           sintab(i-2)=sin1
1887           costab(i-2)=cos1
1888           obrot(1,i-2)=cos1
1889           obrot(2,i-2)=sin1
1890           sin2=dsin(2*phi(i))
1891           cos2=dcos(2*phi(i))
1892           sintab2(i-2)=sin2
1893           costab2(i-2)=cos2
1894           obrot2(1,i-2)=cos2
1895           obrot2(2,i-2)=sin2
1896           Ug(1,1,i-2)=-cos1
1897           Ug(1,2,i-2)=-sin1
1898           Ug(2,1,i-2)=-sin1
1899           Ug(2,2,i-2)= cos1
1900           Ug2(1,1,i-2)=-cos2
1901           Ug2(1,2,i-2)=-sin2
1902           Ug2(2,1,i-2)=-sin2
1903           Ug2(2,2,i-2)= cos2
1904         else
1905           costab(i-2)=1.0d0
1906           sintab(i-2)=0.0d0
1907           obrot(1,i-2)=1.0d0
1908           obrot(2,i-2)=0.0d0
1909           obrot2(1,i-2)=0.0d0
1910           obrot2(2,i-2)=0.0d0
1911           Ug(1,1,i-2)=1.0d0
1912           Ug(1,2,i-2)=0.0d0
1913           Ug(2,1,i-2)=0.0d0
1914           Ug(2,2,i-2)=1.0d0
1915           Ug2(1,1,i-2)=0.0d0
1916           Ug2(1,2,i-2)=0.0d0
1917           Ug2(2,1,i-2)=0.0d0
1918           Ug2(2,2,i-2)=0.0d0
1919         endif
1920         if (i .gt. 3 .and. i .lt. nres+1) then
1921           obrot_der(1,i-2)=-sin1
1922           obrot_der(2,i-2)= cos1
1923           Ugder(1,1,i-2)= sin1
1924           Ugder(1,2,i-2)=-cos1
1925           Ugder(2,1,i-2)=-cos1
1926           Ugder(2,2,i-2)=-sin1
1927           dwacos2=cos2+cos2
1928           dwasin2=sin2+sin2
1929           obrot2_der(1,i-2)=-dwasin2
1930           obrot2_der(2,i-2)= dwacos2
1931           Ug2der(1,1,i-2)= dwasin2
1932           Ug2der(1,2,i-2)=-dwacos2
1933           Ug2der(2,1,i-2)=-dwacos2
1934           Ug2der(2,2,i-2)=-dwasin2
1935         else
1936           obrot_der(1,i-2)=0.0d0
1937           obrot_der(2,i-2)=0.0d0
1938           Ugder(1,1,i-2)=0.0d0
1939           Ugder(1,2,i-2)=0.0d0
1940           Ugder(2,1,i-2)=0.0d0
1941           Ugder(2,2,i-2)=0.0d0
1942           obrot2_der(1,i-2)=0.0d0
1943           obrot2_der(2,i-2)=0.0d0
1944           Ug2der(1,1,i-2)=0.0d0
1945           Ug2der(1,2,i-2)=0.0d0
1946           Ug2der(2,1,i-2)=0.0d0
1947           Ug2der(2,2,i-2)=0.0d0
1948         endif
1949         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1950           if (itype(i-2).le.ntyp) then
1951             iti = itortyp(itype(i-2))
1952           else
1953             iti=ntortyp+1
1954           endif
1955         else
1956           iti=ntortyp+1
1957         endif
1958         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1959           if (itype(i-1).le.ntyp) then
1960             iti1 = itortyp(itype(i-1))
1961           else
1962             iti1=ntortyp+1
1963           endif
1964         else
1965           iti1=ntortyp+1
1966         endif
1967 cd        write (iout,*) '*******i',i,' iti1',iti
1968 cd        write (iout,*) 'b1',b1(:,iti)
1969 cd        write (iout,*) 'b2',b2(:,iti)
1970 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1971 c        print *,"itilde1 i iti iti1",i,iti,iti1
1972         if (i .gt. iatel_s+2) then
1973           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1974           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1975           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1976           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1977           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1978           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1979           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1980         else
1981           do k=1,2
1982             Ub2(k,i-2)=0.0d0
1983             Ctobr(k,i-2)=0.0d0
1984             Dtobr2(k,i-2)=0.0d0
1985             do l=1,2
1986               EUg(l,k,i-2)=0.0d0
1987               CUg(l,k,i-2)=0.0d0
1988               DUg(l,k,i-2)=0.0d0
1989               DtUg2(l,k,i-2)=0.0d0
1990             enddo
1991           enddo
1992         endif
1993 c        print *,"itilde2 i iti iti1",i,iti,iti1
1994         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1995         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1996         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1997         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1998         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1999         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2000         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2001 c        print *,"itilde3 i iti iti1",i,iti,iti1
2002         do k=1,2
2003           muder(k,i-2)=Ub2der(k,i-2)
2004         enddo
2005         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2006           if (itype(i-1).le.ntyp) then
2007             iti1 = itortyp(itype(i-1))
2008           else
2009             iti1=ntortyp+1
2010           endif
2011         else
2012           iti1=ntortyp+1
2013         endif
2014         do k=1,2
2015           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2016         enddo
2017 C        write (iout,*) 'mumu',i,b1(1,iti),Ub2(1,i-2)
2018
2019 C Vectors and matrices dependent on a single virtual-bond dihedral.
2020         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2021         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2022         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2023         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2024         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2025         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2026         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2027         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2028         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2029 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2030 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2031       enddo
2032 C Matrices dependent on two consecutive virtual-bond dihedrals.
2033 C The order of matrices is from left to right.
2034       do i=2,nres-1
2035         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2036         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2037         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2038         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2039         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2040         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2041         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2042         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2043       enddo
2044 cd      do i=1,nres
2045 cd        iti = itortyp(itype(i))
2046 cd        write (iout,*) i
2047 cd        do j=1,2
2048 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2049 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2050 cd        enddo
2051 cd      enddo
2052       return
2053       end
2054 C--------------------------------------------------------------------------
2055       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2056 C
2057 C This subroutine calculates the average interaction energy and its gradient
2058 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2059 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2060 C The potential depends both on the distance of peptide-group centers and on
2061 C the orientation of the CA-CA virtual bonds.
2062 C
2063       implicit real*8 (a-h,o-z)
2064       include 'DIMENSIONS'
2065       include 'DIMENSIONS.ZSCOPT'
2066       include 'COMMON.CONTROL'
2067       include 'COMMON.IOUNITS'
2068       include 'COMMON.GEO'
2069       include 'COMMON.VAR'
2070       include 'COMMON.LOCAL'
2071       include 'COMMON.CHAIN'
2072       include 'COMMON.DERIV'
2073       include 'COMMON.INTERACT'
2074       include 'COMMON.CONTACTS'
2075       include 'COMMON.TORSION'
2076       include 'COMMON.VECTORS'
2077       include 'COMMON.FFIELD'
2078       include 'COMMON.SHIELD'
2079       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2080      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2081       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2082      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2083       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2084 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2085       double precision scal_el /0.5d0/
2086 C 12/13/98
2087 C 13-go grudnia roku pamietnego...
2088       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2089      &                   0.0d0,1.0d0,0.0d0,
2090      &                   0.0d0,0.0d0,1.0d0/
2091 cd      write(iout,*) 'In EELEC'
2092 cd      do i=1,nloctyp
2093 cd        write(iout,*) 'Type',i
2094 cd        write(iout,*) 'B1',B1(:,i)
2095 cd        write(iout,*) 'B2',B2(:,i)
2096 cd        write(iout,*) 'CC',CC(:,:,i)
2097 cd        write(iout,*) 'DD',DD(:,:,i)
2098 cd        write(iout,*) 'EE',EE(:,:,i)
2099 cd      enddo
2100 cd      call check_vecgrad
2101 cd      stop
2102       if (icheckgrad.eq.1) then
2103         do i=1,nres-1
2104           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2105           do k=1,3
2106             dc_norm(k,i)=dc(k,i)*fac
2107           enddo
2108 c          write (iout,*) 'i',i,' fac',fac
2109         enddo
2110       endif
2111       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2112      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2113      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2114 cd      if (wel_loc.gt.0.0d0) then
2115         if (icheckgrad.eq.1) then
2116         call vec_and_deriv_test
2117         else
2118         call vec_and_deriv
2119         endif
2120         call set_matrices
2121       endif
2122 cd      do i=1,nres-1
2123 cd        write (iout,*) 'i=',i
2124 cd        do k=1,3
2125 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2126 cd        enddo
2127 cd        do k=1,3
2128 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2129 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2130 cd        enddo
2131 cd      enddo
2132       num_conti_hb=0
2133       ees=0.0D0
2134       evdw1=0.0D0
2135       eel_loc=0.0d0
2136       eello_turn3=0.0d0
2137       eello_turn4=0.0d0
2138       ind=0
2139       do i=1,nres
2140         num_cont_hb(i)=0
2141       enddo
2142 C      print '(a)','Enter EELEC'
2143 C      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2144       do i=1,nres
2145         gel_loc_loc(i)=0.0d0
2146         gcorr_loc(i)=0.0d0
2147       enddo
2148       do i=iatel_s,iatel_e
2149 C          if (i.eq.1) then
2150            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2151 C     &  .or. itype(i+2).eq.ntyp1) cycle
2152 C          else
2153 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2154 C     &  .or. itype(i+2).eq.ntyp1
2155 C     &  .or. itype(i-1).eq.ntyp1
2156      &) cycle
2157 C         endif
2158         if (itel(i).eq.0) goto 1215
2159         dxi=dc(1,i)
2160         dyi=dc(2,i)
2161         dzi=dc(3,i)
2162         dx_normi=dc_norm(1,i)
2163         dy_normi=dc_norm(2,i)
2164         dz_normi=dc_norm(3,i)
2165         xmedi=c(1,i)+0.5d0*dxi
2166         ymedi=c(2,i)+0.5d0*dyi
2167         zmedi=c(3,i)+0.5d0*dzi
2168           xmedi=mod(xmedi,boxxsize)
2169           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2170           ymedi=mod(ymedi,boxysize)
2171           if (ymedi.lt.0) ymedi=ymedi+boxysize
2172           zmedi=mod(zmedi,boxzsize)
2173           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2174         num_conti=0
2175 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2176         do j=ielstart(i),ielend(i)
2177           if (j.le.1) cycle
2178 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2179 C     & .or.itype(j+2).eq.ntyp1
2180 C     &) cycle
2181 C          else
2182           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2183 C     & .or.itype(j+2).eq.ntyp1
2184 C     & .or.itype(j-1).eq.ntyp1
2185      &) cycle
2186 C         endif
2187 C
2188 C) cycle
2189           if (itel(j).eq.0) goto 1216
2190           ind=ind+1
2191           iteli=itel(i)
2192           itelj=itel(j)
2193           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2194           aaa=app(iteli,itelj)
2195           bbb=bpp(iteli,itelj)
2196 C Diagnostics only!!!
2197 c         aaa=0.0D0
2198 c         bbb=0.0D0
2199 c         ael6i=0.0D0
2200 c         ael3i=0.0D0
2201 C End diagnostics
2202           ael6i=ael6(iteli,itelj)
2203           ael3i=ael3(iteli,itelj)
2204           dxj=dc(1,j)
2205           dyj=dc(2,j)
2206           dzj=dc(3,j)
2207           dx_normj=dc_norm(1,j)
2208           dy_normj=dc_norm(2,j)
2209           dz_normj=dc_norm(3,j)
2210           xj=c(1,j)+0.5D0*dxj
2211           yj=c(2,j)+0.5D0*dyj
2212           zj=c(3,j)+0.5D0*dzj
2213          xj=mod(xj,boxxsize)
2214           if (xj.lt.0) xj=xj+boxxsize
2215           yj=mod(yj,boxysize)
2216           if (yj.lt.0) yj=yj+boxysize
2217           zj=mod(zj,boxzsize)
2218           if (zj.lt.0) zj=zj+boxzsize
2219       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2220       xj_safe=xj
2221       yj_safe=yj
2222       zj_safe=zj
2223       isubchap=0
2224       do xshift=-1,1
2225       do yshift=-1,1
2226       do zshift=-1,1
2227           xj=xj_safe+xshift*boxxsize
2228           yj=yj_safe+yshift*boxysize
2229           zj=zj_safe+zshift*boxzsize
2230           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2231           if(dist_temp.lt.dist_init) then
2232             dist_init=dist_temp
2233             xj_temp=xj
2234             yj_temp=yj
2235             zj_temp=zj
2236             isubchap=1
2237           endif
2238        enddo
2239        enddo
2240        enddo
2241        if (isubchap.eq.1) then
2242           xj=xj_temp-xmedi
2243           yj=yj_temp-ymedi
2244           zj=zj_temp-zmedi
2245        else
2246           xj=xj_safe-xmedi
2247           yj=yj_safe-ymedi
2248           zj=zj_safe-zmedi
2249        endif
2250           rij=xj*xj+yj*yj+zj*zj
2251             sss=sscale(sqrt(rij))
2252             sssgrad=sscagrad(sqrt(rij))
2253           rrmij=1.0D0/rij
2254           rij=dsqrt(rij)
2255           rmij=1.0D0/rij
2256           r3ij=rrmij*rmij
2257           r6ij=r3ij*r3ij
2258           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2259           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2260           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2261           fac=cosa-3.0D0*cosb*cosg
2262           ev1=aaa*r6ij*r6ij
2263 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2264           if (j.eq.i+2) ev1=scal_el*ev1
2265           ev2=bbb*r6ij
2266           fac3=ael6i*r6ij
2267           fac4=ael3i*r3ij
2268           evdwij=ev1+ev2
2269           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2270           el2=fac4*fac
2271           eesij=el1+el2
2272 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2273 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2274           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2275           if (shield_mode.gt.0) then
2276 C#define DEBUG
2277 #ifdef DEBUG
2278           write(iout,*) "ees_compon",i,j,el1,el2,
2279      &    fac_shield(i),fac_shield(j)
2280 #endif
2281 C#undef DEBUG
2282 C          fac_shield(i)=0.4
2283 C          fac_shield(j)=0.6
2284           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2285           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2286           eesij=(el1+el2)
2287           ees=ees+eesij
2288           else
2289           fac_shield(i)=1.0
2290           fac_shield(j)=1.0
2291           eesij=(el1+el2)
2292           ees=ees+eesij
2293           endif
2294           evdw1=evdw1+evdwij*sss
2295 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2296 c     &'evdw1',i,j,evdwij
2297 c     &,iteli,itelj,aaa,evdw1
2298
2299 C              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2300 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2301 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2302 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2303 c     &      xmedi,ymedi,zmedi,xj,yj,zj
2304 C
2305 C Calculate contributions to the Cartesian gradient.
2306 C
2307 #ifdef SPLITELE
2308           facvdw=-6*rrmij*(ev1+evdwij)*sss
2309           facel=-3*rrmij*(el1+eesij)
2310           fac1=fac
2311           erij(1)=xj*rmij
2312           erij(2)=yj*rmij
2313           erij(3)=zj*rmij
2314           if (calc_grad) then
2315 *
2316 * Radial derivatives. First process both termini of the fragment (i,j)
2317 *
2318           ggg(1)=facel*xj
2319           ggg(2)=facel*yj
2320           ggg(3)=facel*zj
2321           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2322      &  (shield_mode.gt.0)) then
2323 C          print *,i,j
2324           do ilist=1,ishield_list(i)
2325            iresshield=shield_list(ilist,i)
2326            do k=1,3
2327            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2328      &      *2.0
2329            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2330      &              rlocshield
2331      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2332             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2333 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2334 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2335 C             if (iresshield.gt.i) then
2336 C               do ishi=i+1,iresshield-1
2337 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2338 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2339 C
2340 C              enddo
2341 C             else
2342 C               do ishi=iresshield,i
2343 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2344 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2345 C
2346 C               enddo
2347 C              endif
2348            enddo
2349           enddo
2350           do ilist=1,ishield_list(j)
2351            iresshield=shield_list(ilist,j)
2352            do k=1,3
2353            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2354      &     *2.0
2355            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2356      &              rlocshield
2357      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2358            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2359            enddo
2360           enddo
2361
2362           do k=1,3
2363             gshieldc(k,i)=gshieldc(k,i)+
2364      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2365             gshieldc(k,j)=gshieldc(k,j)+
2366      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2367             gshieldc(k,i-1)=gshieldc(k,i-1)+
2368      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2369             gshieldc(k,j-1)=gshieldc(k,j-1)+
2370      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2371
2372            enddo
2373            endif
2374
2375           do k=1,3
2376             ghalf=0.5D0*ggg(k)
2377             gelc(k,i)=gelc(k,i)+ghalf
2378             gelc(k,j)=gelc(k,j)+ghalf
2379           enddo
2380 *
2381 * Loop over residues i+1 thru j-1.
2382 *
2383           do k=i+1,j-1
2384             do l=1,3
2385               gelc(l,k)=gelc(l,k)+ggg(l)
2386             enddo
2387           enddo
2388 C          ggg(1)=facvdw*xj
2389 C          ggg(2)=facvdw*yj
2390 C          ggg(3)=facvdw*zj
2391           if (sss.gt.0.0) then
2392           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2393           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2394           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2395           else
2396           ggg(1)=0.0
2397           ggg(2)=0.0
2398           ggg(3)=0.0
2399           endif
2400           do k=1,3
2401             ghalf=0.5D0*ggg(k)
2402             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2403             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2404           enddo
2405 *
2406 * Loop over residues i+1 thru j-1.
2407 *
2408           do k=i+1,j-1
2409             do l=1,3
2410               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2411             enddo
2412           enddo
2413 #else
2414           facvdw=(ev1+evdwij)*sss
2415           facel=el1+eesij
2416           fac1=fac
2417           fac=-3*rrmij*(facvdw+facvdw+facel)
2418           erij(1)=xj*rmij
2419           erij(2)=yj*rmij
2420           erij(3)=zj*rmij
2421           if (calc_grad) then
2422 *
2423 * Radial derivatives. First process both termini of the fragment (i,j)
2424 *
2425           ggg(1)=fac*xj
2426           ggg(2)=fac*yj
2427           ggg(3)=fac*zj
2428           do k=1,3
2429             ghalf=0.5D0*ggg(k)
2430             gelc(k,i)=gelc(k,i)+ghalf
2431             gelc(k,j)=gelc(k,j)+ghalf
2432           enddo
2433 *
2434 * Loop over residues i+1 thru j-1.
2435 *
2436           do k=i+1,j-1
2437             do l=1,3
2438               gelc(l,k)=gelc(l,k)+ggg(l)
2439             enddo
2440           enddo
2441 #endif
2442 *
2443 * Angular part
2444 *
2445           ecosa=2.0D0*fac3*fac1+fac4
2446           fac4=-3.0D0*fac4
2447           fac3=-6.0D0*fac3
2448           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2449           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2450           do k=1,3
2451             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2452             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2453           enddo
2454 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2455 cd   &          (dcosg(k),k=1,3)
2456           do k=1,3
2457             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2458      &      *fac_shield(i)**2*fac_shield(j)**2
2459           enddo
2460           do k=1,3
2461             ghalf=0.5D0*ggg(k)
2462             gelc(k,i)=gelc(k,i)+ghalf
2463      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2464      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2465      &           *fac_shield(i)**2*fac_shield(j)**2
2466
2467             gelc(k,j)=gelc(k,j)+ghalf
2468      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2469      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2470      &           *fac_shield(i)**2*fac_shield(j)**2
2471           enddo
2472           do k=i+1,j-1
2473             do l=1,3
2474               gelc(l,k)=gelc(l,k)+ggg(l)
2475             enddo
2476           enddo
2477           endif
2478
2479           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2480      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2481      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2482 C
2483 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2484 C   energy of a peptide unit is assumed in the form of a second-order
2485 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2486 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2487 C   are computed for EVERY pair of non-contiguous peptide groups.
2488 C
2489           if (j.lt.nres-1) then
2490             j1=j+1
2491             j2=j-1
2492           else
2493             j1=j-1
2494             j2=j-2
2495           endif
2496           kkk=0
2497           do k=1,2
2498             do l=1,2
2499               kkk=kkk+1
2500               muij(kkk)=mu(k,i)*mu(l,j)
2501             enddo
2502           enddo
2503 cd         write (iout,*) 'EELEC: i',i,' j',j
2504 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2505 cd          write(iout,*) 'muij',muij
2506           ury=scalar(uy(1,i),erij)
2507           urz=scalar(uz(1,i),erij)
2508           vry=scalar(uy(1,j),erij)
2509           vrz=scalar(uz(1,j),erij)
2510           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2511           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2512           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2513           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2514 C For diagnostics only
2515 cd          a22=1.0d0
2516 cd          a23=1.0d0
2517 cd          a32=1.0d0
2518 cd          a33=1.0d0
2519           fac=dsqrt(-ael6i)*r3ij
2520 cd          write (2,*) 'fac=',fac
2521 C For diagnostics only
2522 cd          fac=1.0d0
2523           a22=a22*fac
2524           a23=a23*fac
2525           a32=a32*fac
2526           a33=a33*fac
2527 cd          write (iout,'(4i5,4f10.5)')
2528 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2529 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2530 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2531 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2532 cd          write (iout,'(4f10.5)')
2533 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2534 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2535 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2536 cd           write (iout,'(2i3,9f10.5/)') i,j,
2537 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2538           if (calc_grad) then
2539 C Derivatives of the elements of A in virtual-bond vectors
2540           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2541 cd          do k=1,3
2542 cd            do l=1,3
2543 cd              erder(k,l)=0.0d0
2544 cd            enddo
2545 cd          enddo
2546           do k=1,3
2547             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2548             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2549             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2550             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2551             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2552             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2553             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2554             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2555             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2556             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2557             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2558             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2559           enddo
2560 cd          do k=1,3
2561 cd            do l=1,3
2562 cd              uryg(k,l)=0.0d0
2563 cd              urzg(k,l)=0.0d0
2564 cd              vryg(k,l)=0.0d0
2565 cd              vrzg(k,l)=0.0d0
2566 cd            enddo
2567 cd          enddo
2568 C Compute radial contributions to the gradient
2569           facr=-3.0d0*rrmij
2570           a22der=a22*facr
2571           a23der=a23*facr
2572           a32der=a32*facr
2573           a33der=a33*facr
2574 cd          a22der=0.0d0
2575 cd          a23der=0.0d0
2576 cd          a32der=0.0d0
2577 cd          a33der=0.0d0
2578           agg(1,1)=a22der*xj
2579           agg(2,1)=a22der*yj
2580           agg(3,1)=a22der*zj
2581           agg(1,2)=a23der*xj
2582           agg(2,2)=a23der*yj
2583           agg(3,2)=a23der*zj
2584           agg(1,3)=a32der*xj
2585           agg(2,3)=a32der*yj
2586           agg(3,3)=a32der*zj
2587           agg(1,4)=a33der*xj
2588           agg(2,4)=a33der*yj
2589           agg(3,4)=a33der*zj
2590 C Add the contributions coming from er
2591           fac3=-3.0d0*fac
2592           do k=1,3
2593             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2594             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2595             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2596             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2597           enddo
2598           do k=1,3
2599 C Derivatives in DC(i)
2600             ghalf1=0.5d0*agg(k,1)
2601             ghalf2=0.5d0*agg(k,2)
2602             ghalf3=0.5d0*agg(k,3)
2603             ghalf4=0.5d0*agg(k,4)
2604             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2605      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2606             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2607      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2608             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2609      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2610             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2611      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2612 C Derivatives in DC(i+1)
2613             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2614      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2615             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2616      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2617             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2618      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2619             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2620      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2621 C Derivatives in DC(j)
2622             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2623      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2624             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2625      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2626             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2627      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2628             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2629      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2630 C Derivatives in DC(j+1) or DC(nres-1)
2631             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2632      &      -3.0d0*vryg(k,3)*ury)
2633             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2634      &      -3.0d0*vrzg(k,3)*ury)
2635             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2636      &      -3.0d0*vryg(k,3)*urz)
2637             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2638      &      -3.0d0*vrzg(k,3)*urz)
2639 cd            aggi(k,1)=ghalf1
2640 cd            aggi(k,2)=ghalf2
2641 cd            aggi(k,3)=ghalf3
2642 cd            aggi(k,4)=ghalf4
2643 C Derivatives in DC(i+1)
2644 cd            aggi1(k,1)=agg(k,1)
2645 cd            aggi1(k,2)=agg(k,2)
2646 cd            aggi1(k,3)=agg(k,3)
2647 cd            aggi1(k,4)=agg(k,4)
2648 C Derivatives in DC(j)
2649 cd            aggj(k,1)=ghalf1
2650 cd            aggj(k,2)=ghalf2
2651 cd            aggj(k,3)=ghalf3
2652 cd            aggj(k,4)=ghalf4
2653 C Derivatives in DC(j+1)
2654 cd            aggj1(k,1)=0.0d0
2655 cd            aggj1(k,2)=0.0d0
2656 cd            aggj1(k,3)=0.0d0
2657 cd            aggj1(k,4)=0.0d0
2658             if (j.eq.nres-1 .and. i.lt.j-2) then
2659               do l=1,4
2660                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2661 cd                aggj1(k,l)=agg(k,l)
2662               enddo
2663             endif
2664           enddo
2665           endif
2666 c          goto 11111
2667 C Check the loc-el terms by numerical integration
2668           acipa(1,1)=a22
2669           acipa(1,2)=a23
2670           acipa(2,1)=a32
2671           acipa(2,2)=a33
2672           a22=-a22
2673           a23=-a23
2674           do l=1,2
2675             do k=1,3
2676               agg(k,l)=-agg(k,l)
2677               aggi(k,l)=-aggi(k,l)
2678               aggi1(k,l)=-aggi1(k,l)
2679               aggj(k,l)=-aggj(k,l)
2680               aggj1(k,l)=-aggj1(k,l)
2681             enddo
2682           enddo
2683           if (j.lt.nres-1) then
2684             a22=-a22
2685             a32=-a32
2686             do l=1,3,2
2687               do k=1,3
2688                 agg(k,l)=-agg(k,l)
2689                 aggi(k,l)=-aggi(k,l)
2690                 aggi1(k,l)=-aggi1(k,l)
2691                 aggj(k,l)=-aggj(k,l)
2692                 aggj1(k,l)=-aggj1(k,l)
2693               enddo
2694             enddo
2695           else
2696             a22=-a22
2697             a23=-a23
2698             a32=-a32
2699             a33=-a33
2700             do l=1,4
2701               do k=1,3
2702                 agg(k,l)=-agg(k,l)
2703                 aggi(k,l)=-aggi(k,l)
2704                 aggi1(k,l)=-aggi1(k,l)
2705                 aggj(k,l)=-aggj(k,l)
2706                 aggj1(k,l)=-aggj1(k,l)
2707               enddo
2708             enddo
2709           endif
2710           ENDIF ! WCORR
2711 11111     continue
2712           IF (wel_loc.gt.0.0d0) THEN
2713 C Contribution to the local-electrostatic energy coming from the i-j pair
2714           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2715      &     +a33*muij(4)
2716           if (shield_mode.eq.0) then
2717            fac_shield(i)=1.0
2718            fac_shield(j)=1.0
2719 C          else
2720 C           fac_shield(i)=0.4
2721 C           fac_shield(j)=0.6
2722           endif
2723           eel_loc_ij=eel_loc_ij
2724      &    *fac_shield(i)*fac_shield(j)
2725 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2726 C          write (iout,'(a6,2i5,0pf7.3)')
2727 C     &            'eelloc',i,j,eel_loc_ij
2728 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2729 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2730 C          eel_loc=eel_loc+eel_loc_ij
2731           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2732      &  (shield_mode.gt.0)) then
2733 C          print *,i,j
2734
2735           do ilist=1,ishield_list(i)
2736            iresshield=shield_list(ilist,i)
2737            do k=1,3
2738            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2739      &                                          /fac_shield(i)
2740 C     &      *2.0
2741            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2742      &              rlocshield
2743      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2744             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2745      &      +rlocshield
2746            enddo
2747           enddo
2748           do ilist=1,ishield_list(j)
2749            iresshield=shield_list(ilist,j)
2750            do k=1,3
2751            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2752      &                                       /fac_shield(j)
2753 C     &     *2.0
2754            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2755      &              rlocshield
2756      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2757            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2758      &             +rlocshield
2759
2760            enddo
2761           enddo
2762           do k=1,3
2763             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2764      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2765             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2766      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2767             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2768      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2769             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2770      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2771            enddo
2772            endif
2773           eel_loc=eel_loc+eel_loc_ij
2774
2775 C Partial derivatives in virtual-bond dihedral angles gamma
2776           if (calc_grad) then
2777           if (i.gt.1)
2778      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2779      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2780      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
2781      &    *fac_shield(i)*fac_shield(j)
2782
2783           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2784      &            (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2785      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
2786      &    *fac_shield(i)*fac_shield(j)
2787
2788 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2789 cd          write(iout,*) 'agg  ',agg
2790 cd          write(iout,*) 'aggi ',aggi
2791 cd          write(iout,*) 'aggi1',aggi1
2792 cd          write(iout,*) 'aggj ',aggj
2793 cd          write(iout,*) 'aggj1',aggj1
2794
2795 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2796           do l=1,3
2797             ggg(l)=(agg(l,1)*muij(1)+
2798      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
2799      &    *fac_shield(i)*fac_shield(j)
2800
2801           enddo
2802           do k=i+2,j2
2803             do l=1,3
2804               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2805             enddo
2806           enddo
2807 C Remaining derivatives of eello
2808           do l=1,3
2809             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
2810      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
2811      &    *fac_shield(i)*fac_shield(j)
2812
2813             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
2814      &         aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
2815      &    *fac_shield(i)*fac_shield(j)
2816
2817             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
2818      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
2819      &    *fac_shield(i)*fac_shield(j)
2820
2821             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
2822      &         aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
2823      &    *fac_shield(i)*fac_shield(j)
2824
2825           enddo
2826           endif
2827           ENDIF
2828           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2829 C Contributions from turns
2830             a_temp(1,1)=a22
2831             a_temp(1,2)=a23
2832             a_temp(2,1)=a32
2833             a_temp(2,2)=a33
2834             call eturn34(i,j,eello_turn3,eello_turn4)
2835           endif
2836 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2837           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2838 C
2839 C Calculate the contact function. The ith column of the array JCONT will
2840 C contain the numbers of atoms that make contacts with the atom I (of numbers
2841 C greater than I). The arrays FACONT and GACONT will contain the values of
2842 C the contact function and its derivative.
2843 c           r0ij=1.02D0*rpp(iteli,itelj)
2844 c           r0ij=1.11D0*rpp(iteli,itelj)
2845             r0ij=2.20D0*rpp(iteli,itelj)
2846 c           r0ij=1.55D0*rpp(iteli,itelj)
2847             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2848             if (fcont.gt.0.0D0) then
2849               num_conti=num_conti+1
2850               if (num_conti.gt.maxconts) then
2851                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2852      &                         ' will skip next contacts for this conf.'
2853               else
2854                 jcont_hb(num_conti,i)=j
2855                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2856      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2857 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2858 C  terms.
2859                 d_cont(num_conti,i)=rij
2860 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2861 C     --- Electrostatic-interaction matrix ---
2862                 a_chuj(1,1,num_conti,i)=a22
2863                 a_chuj(1,2,num_conti,i)=a23
2864                 a_chuj(2,1,num_conti,i)=a32
2865                 a_chuj(2,2,num_conti,i)=a33
2866 C     --- Gradient of rij
2867                 do kkk=1,3
2868                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2869                 enddo
2870 c             if (i.eq.1) then
2871 c                a_chuj(1,1,num_conti,i)=-0.61d0
2872 c                a_chuj(1,2,num_conti,i)= 0.4d0
2873 c                a_chuj(2,1,num_conti,i)= 0.65d0
2874 c                a_chuj(2,2,num_conti,i)= 0.50d0
2875 c             else if (i.eq.2) then
2876 c                a_chuj(1,1,num_conti,i)= 0.0d0
2877 c                a_chuj(1,2,num_conti,i)= 0.0d0
2878 c                a_chuj(2,1,num_conti,i)= 0.0d0
2879 c                a_chuj(2,2,num_conti,i)= 0.0d0
2880 c             endif
2881 C     --- and its gradients
2882 cd                write (iout,*) 'i',i,' j',j
2883 cd                do kkk=1,3
2884 cd                write (iout,*) 'iii 1 kkk',kkk
2885 cd                write (iout,*) agg(kkk,:)
2886 cd                enddo
2887 cd                do kkk=1,3
2888 cd                write (iout,*) 'iii 2 kkk',kkk
2889 cd                write (iout,*) aggi(kkk,:)
2890 cd                enddo
2891 cd                do kkk=1,3
2892 cd                write (iout,*) 'iii 3 kkk',kkk
2893 cd                write (iout,*) aggi1(kkk,:)
2894 cd                enddo
2895 cd                do kkk=1,3
2896 cd                write (iout,*) 'iii 4 kkk',kkk
2897 cd                write (iout,*) aggj(kkk,:)
2898 cd                enddo
2899 cd                do kkk=1,3
2900 cd                write (iout,*) 'iii 5 kkk',kkk
2901 cd                write (iout,*) aggj1(kkk,:)
2902 cd                enddo
2903                 kkll=0
2904                 do k=1,2
2905                   do l=1,2
2906                     kkll=kkll+1
2907                     do m=1,3
2908                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2909                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2910                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2911                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2912                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2913 c                      do mm=1,5
2914 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2915 c                      enddo
2916                     enddo
2917                   enddo
2918                 enddo
2919                 ENDIF
2920                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2921 C Calculate contact energies
2922                 cosa4=4.0D0*cosa
2923                 wij=cosa-3.0D0*cosb*cosg
2924                 cosbg1=cosb+cosg
2925                 cosbg2=cosb-cosg
2926 c               fac3=dsqrt(-ael6i)/r0ij**3
2927                 fac3=dsqrt(-ael6i)*r3ij
2928                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2929                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2930 c               ees0mij=0.0D0
2931                 if (shield_mode.eq.0) then
2932                 fac_shield(i)=1.0d0
2933                 fac_shield(j)=1.0d0
2934                 else
2935                 ees0plist(num_conti,i)=j
2936 C                fac_shield(i)=0.4d0
2937 C                fac_shield(j)=0.6d0
2938                 endif
2939                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2940      &          *fac_shield(i)*fac_shield(j)
2941
2942                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2943      &          *fac_shield(i)*fac_shield(j)
2944
2945 C Diagnostics. Comment out or remove after debugging!
2946 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2947 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2948 c               ees0m(num_conti,i)=0.0D0
2949 C End diagnostics.
2950 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2951 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2952                 facont_hb(num_conti,i)=fcont
2953                 if (calc_grad) then
2954 C Angular derivatives of the contact function
2955                 ees0pij1=fac3/ees0pij
2956                 ees0mij1=fac3/ees0mij
2957                 fac3p=-3.0D0*fac3*rrmij
2958                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2959                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2960 c               ees0mij1=0.0D0
2961                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2962                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2963                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2964                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2965                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2966                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2967                 ecosap=ecosa1+ecosa2
2968                 ecosbp=ecosb1+ecosb2
2969                 ecosgp=ecosg1+ecosg2
2970                 ecosam=ecosa1-ecosa2
2971                 ecosbm=ecosb1-ecosb2
2972                 ecosgm=ecosg1-ecosg2
2973 C Diagnostics
2974 c               ecosap=ecosa1
2975 c               ecosbp=ecosb1
2976 c               ecosgp=ecosg1
2977 c               ecosam=0.0D0
2978 c               ecosbm=0.0D0
2979 c               ecosgm=0.0D0
2980 C End diagnostics
2981                 fprimcont=fprimcont/rij
2982 cd              facont_hb(num_conti,i)=1.0D0
2983 C Following line is for diagnostics.
2984 cd              fprimcont=0.0D0
2985                 do k=1,3
2986                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2987                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2988                 enddo
2989                 do k=1,3
2990                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2991                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2992                 enddo
2993                 gggp(1)=gggp(1)+ees0pijp*xj
2994                 gggp(2)=gggp(2)+ees0pijp*yj
2995                 gggp(3)=gggp(3)+ees0pijp*zj
2996                 gggm(1)=gggm(1)+ees0mijp*xj
2997                 gggm(2)=gggm(2)+ees0mijp*yj
2998                 gggm(3)=gggm(3)+ees0mijp*zj
2999 C Derivatives due to the contact function
3000                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3001                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3002                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3003                 do k=1,3
3004                   ghalfp=0.5D0*gggp(k)
3005                   ghalfm=0.5D0*gggm(k)
3006                   gacontp_hb1(k,num_conti,i)=ghalfp
3007      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3008      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3009      &          *fac_shield(i)*fac_shield(j)
3010
3011                   gacontp_hb2(k,num_conti,i)=ghalfp
3012      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3013      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3014      &          *fac_shield(i)*fac_shield(j)
3015
3016                   gacontp_hb3(k,num_conti,i)=gggp(k)
3017      &          *fac_shield(i)*fac_shield(j)
3018
3019                   gacontm_hb1(k,num_conti,i)=ghalfm
3020      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3021      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3022      &          *fac_shield(i)*fac_shield(j)
3023
3024                   gacontm_hb2(k,num_conti,i)=ghalfm
3025      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3026      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3027      &          *fac_shield(i)*fac_shield(j)
3028
3029                   gacontm_hb3(k,num_conti,i)=gggm(k)
3030      &          *fac_shield(i)*fac_shield(j)
3031
3032                 enddo
3033                 endif
3034 C Diagnostics. Comment out or remove after debugging!
3035 cdiag           do k=1,3
3036 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3037 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3038 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3039 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3040 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3041 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3042 cdiag           enddo
3043               ENDIF ! wcorr
3044               endif  ! num_conti.le.maxconts
3045             endif  ! fcont.gt.0
3046           endif    ! j.gt.i+1
3047  1216     continue
3048         enddo ! j
3049         num_cont_hb(i)=num_conti
3050  1215   continue
3051       enddo   ! i
3052 cd      do i=1,nres
3053 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3054 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3055 cd      enddo
3056 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3057 ccc      eel_loc=eel_loc+eello_turn3
3058       return
3059       end
3060 C-----------------------------------------------------------------------------
3061       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3062 C Third- and fourth-order contributions from turns
3063       implicit real*8 (a-h,o-z)
3064       include 'DIMENSIONS'
3065       include 'DIMENSIONS.ZSCOPT'
3066       include 'COMMON.IOUNITS'
3067       include 'COMMON.GEO'
3068       include 'COMMON.VAR'
3069       include 'COMMON.LOCAL'
3070       include 'COMMON.CHAIN'
3071       include 'COMMON.DERIV'
3072       include 'COMMON.INTERACT'
3073       include 'COMMON.CONTACTS'
3074       include 'COMMON.TORSION'
3075       include 'COMMON.VECTORS'
3076       include 'COMMON.FFIELD'
3077       include 'COMMON.SHIELD'
3078       include 'COMMON.CONTROL'
3079       dimension ggg(3)
3080       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3081      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3082      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3083       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3084      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3085       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3086       if (j.eq.i+2) then
3087       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3088 C changes suggested by Ana to avoid out of bounds
3089 C     & .or.((i+5).gt.nres)
3090 C     & .or.((i-1).le.0)
3091 C end of changes suggested by Ana
3092      &    .or. itype(i+2).eq.ntyp1
3093      &    .or. itype(i+3).eq.ntyp1
3094 C     &    .or. itype(i+5).eq.ntyp1
3095 C     &    .or. itype(i).eq.ntyp1
3096 C     &    .or. itype(i-1).eq.ntyp1
3097      &    ) goto 179
3098
3099 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3100 C
3101 C               Third-order contributions
3102 C
3103 C                 (i+2)o----(i+3)
3104 C                      | |
3105 C                      | |
3106 C                 (i+1)o----i
3107 C
3108 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3109 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3110         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3111         call transpose2(auxmat(1,1),auxmat1(1,1))
3112         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3113         if (shield_mode.eq.0) then
3114         fac_shield(i)=1.0
3115         fac_shield(j)=1.0
3116 C        else
3117 C        fac_shield(i)=0.4
3118 C        fac_shield(j)=0.6
3119         endif
3120
3121         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3122      &  *fac_shield(i)*fac_shield(j)
3123         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3124      &  *fac_shield(i)*fac_shield(j)
3125
3126 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3127 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3128 cd     &    ' eello_turn3_num',4*eello_turn3_num
3129         if (calc_grad) then
3130 C Derivatives in shield mode
3131           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3132      &  (shield_mode.gt.0)) then
3133 C          print *,i,j
3134
3135           do ilist=1,ishield_list(i)
3136            iresshield=shield_list(ilist,i)
3137            do k=1,3
3138            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3139 C     &      *2.0
3140            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3141      &              rlocshield
3142      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3143             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3144      &      +rlocshield
3145            enddo
3146           enddo
3147           do ilist=1,ishield_list(j)
3148            iresshield=shield_list(ilist,j)
3149            do k=1,3
3150            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3151 C     &     *2.0
3152            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3153      &              rlocshield
3154      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3155            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3156      &             +rlocshield
3157
3158            enddo
3159           enddo
3160
3161           do k=1,3
3162             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3163      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3164             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3165      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3166             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3167      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3168             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3169      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3170            enddo
3171            endif
3172
3173 C Derivatives in gamma(i)
3174         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3175         call transpose2(auxmat2(1,1),pizda(1,1))
3176         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3177         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3178      &   *fac_shield(i)*fac_shield(j)
3179 C Derivatives in gamma(i+1)
3180         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3181         call transpose2(auxmat2(1,1),pizda(1,1))
3182         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3183         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3184      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3185      &   *fac_shield(i)*fac_shield(j)
3186
3187 C Cartesian derivatives
3188         do l=1,3
3189           a_temp(1,1)=aggi(l,1)
3190           a_temp(1,2)=aggi(l,2)
3191           a_temp(2,1)=aggi(l,3)
3192           a_temp(2,2)=aggi(l,4)
3193           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3194           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3195      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3196      &   *fac_shield(i)*fac_shield(j)
3197
3198           a_temp(1,1)=aggi1(l,1)
3199           a_temp(1,2)=aggi1(l,2)
3200           a_temp(2,1)=aggi1(l,3)
3201           a_temp(2,2)=aggi1(l,4)
3202           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3203           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3204      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3205      &   *fac_shield(i)*fac_shield(j)
3206
3207           a_temp(1,1)=aggj(l,1)
3208           a_temp(1,2)=aggj(l,2)
3209           a_temp(2,1)=aggj(l,3)
3210           a_temp(2,2)=aggj(l,4)
3211           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3212           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3213      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3214      &   *fac_shield(i)*fac_shield(j)
3215
3216           a_temp(1,1)=aggj1(l,1)
3217           a_temp(1,2)=aggj1(l,2)
3218           a_temp(2,1)=aggj1(l,3)
3219           a_temp(2,2)=aggj1(l,4)
3220           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3221           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3222      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3223      &   *fac_shield(i)*fac_shield(j)
3224
3225         enddo
3226         endif
3227   179 continue
3228       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3229       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3230 C changes suggested by Ana to avoid out of bounds
3231 C     & .or.((i+5).gt.nres)
3232 C     & .or.((i-1).le.0)
3233 C end of changes suggested by Ana
3234      &    .or. itype(i+3).eq.ntyp1
3235      &    .or. itype(i+4).eq.ntyp1
3236 C     &    .or. itype(i+5).eq.ntyp1
3237      &    .or. itype(i).eq.ntyp1
3238 C     &    .or. itype(i-1).eq.ntyp1
3239      &    ) goto 178
3240 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3241 C
3242 C               Fourth-order contributions
3243 C
3244 C                 (i+3)o----(i+4)
3245 C                     /  |
3246 C               (i+2)o   |
3247 C                     \  |
3248 C                 (i+1)o----i
3249 C
3250 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3251 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3252         iti1=itortyp(itype(i+1))
3253         iti2=itortyp(itype(i+2))
3254         iti3=itortyp(itype(i+3))
3255         call transpose2(EUg(1,1,i+1),e1t(1,1))
3256         call transpose2(Eug(1,1,i+2),e2t(1,1))
3257         call transpose2(Eug(1,1,i+3),e3t(1,1))
3258         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3259         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3260         s1=scalar2(b1(1,iti2),auxvec(1))
3261         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3262         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3263         s2=scalar2(b1(1,iti1),auxvec(1))
3264         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3265         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3266         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3267         if (shield_mode.eq.0) then
3268         fac_shield(i)=1.0
3269         fac_shield(j)=1.0
3270 C        else
3271 C        fac_shield(i)=0.4
3272 C        fac_shield(j)=0.6
3273         endif
3274
3275         eello_turn4=eello_turn4-(s1+s2+s3)
3276      &  *fac_shield(i)*fac_shield(j)
3277         eello_t4=-(s1+s2+s3)
3278      &  *fac_shield(i)*fac_shield(j)
3279
3280 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3281 cd     &    ' eello_turn4_num',8*eello_turn4_num
3282 C Derivatives in gamma(i)
3283         if (calc_grad) then
3284           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3285      &  (shield_mode.gt.0)) then
3286 C          print *,i,j
3287
3288           do ilist=1,ishield_list(i)
3289            iresshield=shield_list(ilist,i)
3290            do k=1,3
3291            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3292 C     &      *2.0
3293            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3294      &              rlocshield
3295      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3296             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3297      &      +rlocshield
3298            enddo
3299           enddo
3300           do ilist=1,ishield_list(j)
3301            iresshield=shield_list(ilist,j)
3302            do k=1,3
3303            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3304 C     &     *2.0
3305            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3306      &              rlocshield
3307      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3308            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3309      &             +rlocshield
3310
3311            enddo
3312           enddo
3313
3314           do k=1,3
3315             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3316      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3317             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3318      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3319             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3320      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3321             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3322      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3323            enddo
3324            endif
3325         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3326         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3327         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3328         s1=scalar2(b1(1,iti2),auxvec(1))
3329         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3330         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3331         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3332      &  *fac_shield(i)*fac_shield(j)
3333
3334 C Derivatives in gamma(i+1)
3335         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3336         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3337         s2=scalar2(b1(1,iti1),auxvec(1))
3338         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3339         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3340         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3341         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3342      &  *fac_shield(i)*fac_shield(j)
3343
3344 C Derivatives in gamma(i+2)
3345         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3346         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3347         s1=scalar2(b1(1,iti2),auxvec(1))
3348         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3349         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3350         s2=scalar2(b1(1,iti1),auxvec(1))
3351         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3352         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3353         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3354         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3355      &  *fac_shield(i)*fac_shield(j)
3356
3357 C Cartesian derivatives
3358
3359 C Derivatives of this turn contributions in DC(i+2)
3360         if (j.lt.nres-1) then
3361           do l=1,3
3362             a_temp(1,1)=agg(l,1)
3363             a_temp(1,2)=agg(l,2)
3364             a_temp(2,1)=agg(l,3)
3365             a_temp(2,2)=agg(l,4)
3366             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3367             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3368             s1=scalar2(b1(1,iti2),auxvec(1))
3369             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3370             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3371             s2=scalar2(b1(1,iti1),auxvec(1))
3372             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3373             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3374             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3375             ggg(l)=-(s1+s2+s3)
3376             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3377      &  *fac_shield(i)*fac_shield(j)
3378
3379           enddo
3380         endif
3381 C Remaining derivatives of this turn contribution
3382         do l=1,3
3383           a_temp(1,1)=aggi(l,1)
3384           a_temp(1,2)=aggi(l,2)
3385           a_temp(2,1)=aggi(l,3)
3386           a_temp(2,2)=aggi(l,4)
3387           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3388           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3389           s1=scalar2(b1(1,iti2),auxvec(1))
3390           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3391           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3392           s2=scalar2(b1(1,iti1),auxvec(1))
3393           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3394           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3395           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3396           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3397      &  *fac_shield(i)*fac_shield(j)
3398
3399           a_temp(1,1)=aggi1(l,1)
3400           a_temp(1,2)=aggi1(l,2)
3401           a_temp(2,1)=aggi1(l,3)
3402           a_temp(2,2)=aggi1(l,4)
3403           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3404           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3405           s1=scalar2(b1(1,iti2),auxvec(1))
3406           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3407           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3408           s2=scalar2(b1(1,iti1),auxvec(1))
3409           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3410           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3411           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3412           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3413      &  *fac_shield(i)*fac_shield(j)
3414
3415           a_temp(1,1)=aggj(l,1)
3416           a_temp(1,2)=aggj(l,2)
3417           a_temp(2,1)=aggj(l,3)
3418           a_temp(2,2)=aggj(l,4)
3419           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3420           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3421           s1=scalar2(b1(1,iti2),auxvec(1))
3422           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3423           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3424           s2=scalar2(b1(1,iti1),auxvec(1))
3425           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3426           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3427           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3428           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3429      &  *fac_shield(i)*fac_shield(j)
3430
3431           a_temp(1,1)=aggj1(l,1)
3432           a_temp(1,2)=aggj1(l,2)
3433           a_temp(2,1)=aggj1(l,3)
3434           a_temp(2,2)=aggj1(l,4)
3435           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3436           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3437           s1=scalar2(b1(1,iti2),auxvec(1))
3438           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3439           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3440           s2=scalar2(b1(1,iti1),auxvec(1))
3441           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3442           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3443           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3444           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3445      &  *fac_shield(i)*fac_shield(j)
3446
3447         enddo
3448         endif
3449  178  continue
3450       endif
3451       return
3452       end
3453 C-----------------------------------------------------------------------------
3454       subroutine vecpr(u,v,w)
3455       implicit real*8(a-h,o-z)
3456       dimension u(3),v(3),w(3)
3457       w(1)=u(2)*v(3)-u(3)*v(2)
3458       w(2)=-u(1)*v(3)+u(3)*v(1)
3459       w(3)=u(1)*v(2)-u(2)*v(1)
3460       return
3461       end
3462 C-----------------------------------------------------------------------------
3463       subroutine unormderiv(u,ugrad,unorm,ungrad)
3464 C This subroutine computes the derivatives of a normalized vector u, given
3465 C the derivatives computed without normalization conditions, ugrad. Returns
3466 C ungrad.
3467       implicit none
3468       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3469       double precision vec(3)
3470       double precision scalar
3471       integer i,j
3472 c      write (2,*) 'ugrad',ugrad
3473 c      write (2,*) 'u',u
3474       do i=1,3
3475         vec(i)=scalar(ugrad(1,i),u(1))
3476       enddo
3477 c      write (2,*) 'vec',vec
3478       do i=1,3
3479         do j=1,3
3480           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3481         enddo
3482       enddo
3483 c      write (2,*) 'ungrad',ungrad
3484       return
3485       end
3486 C-----------------------------------------------------------------------------
3487       subroutine escp(evdw2,evdw2_14)
3488 C
3489 C This subroutine calculates the excluded-volume interaction energy between
3490 C peptide-group centers and side chains and its gradient in virtual-bond and
3491 C side-chain vectors.
3492 C
3493       implicit real*8 (a-h,o-z)
3494       include 'DIMENSIONS'
3495       include 'DIMENSIONS.ZSCOPT'
3496       include 'COMMON.GEO'
3497       include 'COMMON.VAR'
3498       include 'COMMON.LOCAL'
3499       include 'COMMON.CHAIN'
3500       include 'COMMON.DERIV'
3501       include 'COMMON.INTERACT'
3502       include 'COMMON.FFIELD'
3503       include 'COMMON.IOUNITS'
3504       dimension ggg(3)
3505       evdw2=0.0D0
3506       evdw2_14=0.0d0
3507 cd    print '(a)','Enter ESCP'
3508 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3509 c     &  ' scal14',scal14
3510       do i=iatscp_s,iatscp_e
3511         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3512         iteli=itel(i)
3513 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3514 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3515         if (iteli.eq.0) goto 1225
3516         xi=0.5D0*(c(1,i)+c(1,i+1))
3517         yi=0.5D0*(c(2,i)+c(2,i+1))
3518         zi=0.5D0*(c(3,i)+c(3,i+1))
3519 C Returning the ith atom to box
3520           xi=mod(xi,boxxsize)
3521           if (xi.lt.0) xi=xi+boxxsize
3522           yi=mod(yi,boxysize)
3523           if (yi.lt.0) yi=yi+boxysize
3524           zi=mod(zi,boxzsize)
3525           if (zi.lt.0) zi=zi+boxzsize
3526         do iint=1,nscp_gr(i)
3527
3528         do j=iscpstart(i,iint),iscpend(i,iint)
3529           itypj=iabs(itype(j))
3530           if (itypj.eq.ntyp1) cycle
3531 C Uncomment following three lines for SC-p interactions
3532 c         xj=c(1,nres+j)-xi
3533 c         yj=c(2,nres+j)-yi
3534 c         zj=c(3,nres+j)-zi
3535 C Uncomment following three lines for Ca-p interactions
3536           xj=c(1,j)
3537           yj=c(2,j)
3538           zj=c(3,j)
3539 C returning the jth atom to box
3540           xj=mod(xj,boxxsize)
3541           if (xj.lt.0) xj=xj+boxxsize
3542           yj=mod(yj,boxysize)
3543           if (yj.lt.0) yj=yj+boxysize
3544           zj=mod(zj,boxzsize)
3545           if (zj.lt.0) zj=zj+boxzsize
3546       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3547       xj_safe=xj
3548       yj_safe=yj
3549       zj_safe=zj
3550       subchap=0
3551 C Finding the closest jth atom
3552       do xshift=-1,1
3553       do yshift=-1,1
3554       do zshift=-1,1
3555           xj=xj_safe+xshift*boxxsize
3556           yj=yj_safe+yshift*boxysize
3557           zj=zj_safe+zshift*boxzsize
3558           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3559           if(dist_temp.lt.dist_init) then
3560             dist_init=dist_temp
3561             xj_temp=xj
3562             yj_temp=yj
3563             zj_temp=zj
3564             subchap=1
3565           endif
3566        enddo
3567        enddo
3568        enddo
3569        if (subchap.eq.1) then
3570           xj=xj_temp-xi
3571           yj=yj_temp-yi
3572           zj=zj_temp-zi
3573        else
3574           xj=xj_safe-xi
3575           yj=yj_safe-yi
3576           zj=zj_safe-zi
3577        endif
3578           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3579 C sss is scaling function for smoothing the cutoff gradient otherwise
3580 C the gradient would not be continuouse
3581           sss=sscale(1.0d0/(dsqrt(rrij)))
3582           if (sss.le.0.0d0) cycle
3583           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3584           fac=rrij**expon2
3585           e1=fac*fac*aad(itypj,iteli)
3586           e2=fac*bad(itypj,iteli)
3587           if (iabs(j-i) .le. 2) then
3588             e1=scal14*e1
3589             e2=scal14*e2
3590             evdw2_14=evdw2_14+(e1+e2)*sss
3591           endif
3592           evdwij=e1+e2
3593 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3594 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3595 c     &       bad(itypj,iteli)
3596           evdw2=evdw2+evdwij*sss
3597           if (calc_grad) then
3598 C
3599 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3600 C
3601           fac=-(evdwij+e1)*rrij*sss
3602           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3603           ggg(1)=xj*fac
3604           ggg(2)=yj*fac
3605           ggg(3)=zj*fac
3606           if (j.lt.i) then
3607 cd          write (iout,*) 'j<i'
3608 C Uncomment following three lines for SC-p interactions
3609 c           do k=1,3
3610 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3611 c           enddo
3612           else
3613 cd          write (iout,*) 'j>i'
3614             do k=1,3
3615               ggg(k)=-ggg(k)
3616 C Uncomment following line for SC-p interactions
3617 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3618             enddo
3619           endif
3620           do k=1,3
3621             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3622           enddo
3623           kstart=min0(i+1,j)
3624           kend=max0(i-1,j-1)
3625 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3626 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3627           do k=kstart,kend
3628             do l=1,3
3629               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3630             enddo
3631           enddo
3632           endif
3633         enddo
3634         enddo ! iint
3635  1225   continue
3636       enddo ! i
3637       do i=1,nct
3638         do j=1,3
3639           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3640           gradx_scp(j,i)=expon*gradx_scp(j,i)
3641         enddo
3642       enddo
3643 C******************************************************************************
3644 C
3645 C                              N O T E !!!
3646 C
3647 C To save time the factor EXPON has been extracted from ALL components
3648 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3649 C use!
3650 C
3651 C******************************************************************************
3652       return
3653       end
3654 C--------------------------------------------------------------------------
3655       subroutine edis(ehpb)
3656 C
3657 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3658 C
3659       implicit real*8 (a-h,o-z)
3660       include 'DIMENSIONS'
3661       include 'DIMENSIONS.ZSCOPT'
3662       include 'COMMON.SBRIDGE'
3663       include 'COMMON.CHAIN'
3664       include 'COMMON.DERIV'
3665       include 'COMMON.VAR'
3666       include 'COMMON.INTERACT'
3667       include 'COMMON.CONTROL'
3668       include 'COMMON.IOUNITS'
3669       dimension ggg(3)
3670       ehpb=0.0D0
3671 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3672 cd    print *,'link_start=',link_start,' link_end=',link_end
3673 C      write(iout,*) link_end, "link_end"
3674       if (link_end.eq.0) return
3675       do i=link_start,link_end
3676 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3677 C CA-CA distance used in regularization of structure.
3678         ii=ihpb(i)
3679         jj=jhpb(i)
3680 C iii and jjj point to the residues for which the distance is assigned.
3681         if (ii.gt.nres) then
3682           iii=ii-nres
3683           jjj=jj-nres
3684         else
3685           iii=ii
3686           jjj=jj
3687         endif
3688 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3689 C    distance and angle dependent SS bond potential.
3690 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3691 C     & iabs(itype(jjj)).eq.1) then
3692 C       write(iout,*) constr_dist,"const"
3693        if (.not.dyn_ss .and. i.le.nss) then
3694          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3695      & iabs(itype(jjj)).eq.1) then
3696           call ssbond_ene(iii,jjj,eij)
3697           ehpb=ehpb+2*eij
3698            endif !ii.gt.neres
3699         else if (ii.gt.nres .and. jj.gt.nres) then
3700 c Restraints from contact prediction
3701           dd=dist(ii,jj)
3702           if (constr_dist.eq.11) then
3703 C            ehpb=ehpb+fordepth(i)**4.0d0
3704 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3705             ehpb=ehpb+fordepth(i)**4.0d0
3706      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3707             fac=fordepth(i)**4.0d0
3708      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3709 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3710 C     &    ehpb,fordepth(i),dd
3711 C            write(iout,*) ehpb,"atu?"
3712 C            ehpb,"tu?"
3713 C            fac=fordepth(i)**4.0d0
3714 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3715            else
3716           if (dhpb1(i).gt.0.0d0) then
3717             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3718             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3719 c            write (iout,*) "beta nmr",
3720 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3721           else
3722             dd=dist(ii,jj)
3723             rdis=dd-dhpb(i)
3724 C Get the force constant corresponding to this distance.
3725             waga=forcon(i)
3726 C Calculate the contribution to energy.
3727             ehpb=ehpb+waga*rdis*rdis
3728 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3729 C
3730 C Evaluate gradient.
3731 C
3732             fac=waga*rdis/dd
3733           endif !end dhpb1(i).gt.0
3734           endif !end const_dist=11
3735           do j=1,3
3736             ggg(j)=fac*(c(j,jj)-c(j,ii))
3737           enddo
3738           do j=1,3
3739             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3740             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3741           enddo
3742           do k=1,3
3743             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3744             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3745           enddo
3746         else !ii.gt.nres
3747 C          write(iout,*) "before"
3748           dd=dist(ii,jj)
3749 C          write(iout,*) "after",dd
3750           if (constr_dist.eq.11) then
3751             ehpb=ehpb+fordepth(i)**4.0d0
3752      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3753             fac=fordepth(i)**4.0d0
3754      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3755 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3756 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3757 C            print *,ehpb,"tu?"
3758 C            write(iout,*) ehpb,"btu?",
3759 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3760 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3761 C     &    ehpb,fordepth(i),dd
3762            else
3763           if (dhpb1(i).gt.0.0d0) then
3764             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3765             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3766 c            write (iout,*) "alph nmr",
3767 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3768           else
3769             rdis=dd-dhpb(i)
3770 C Get the force constant corresponding to this distance.
3771             waga=forcon(i)
3772 C Calculate the contribution to energy.
3773             ehpb=ehpb+waga*rdis*rdis
3774 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3775 C
3776 C Evaluate gradient.
3777 C
3778             fac=waga*rdis/dd
3779           endif
3780           endif
3781
3782         do j=1,3
3783           ggg(j)=fac*(c(j,jj)-c(j,ii))
3784         enddo
3785 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3786 C If this is a SC-SC distance, we need to calculate the contributions to the
3787 C Cartesian gradient in the SC vectors (ghpbx).
3788         if (iii.lt.ii) then
3789           do j=1,3
3790             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3791             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3792           enddo
3793         endif
3794         do j=iii,jjj-1
3795           do k=1,3
3796             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3797           enddo
3798         enddo
3799         endif
3800       enddo
3801       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3802       return
3803       end
3804 C--------------------------------------------------------------------------
3805       subroutine ssbond_ene(i,j,eij)
3806 C
3807 C Calculate the distance and angle dependent SS-bond potential energy
3808 C using a free-energy function derived based on RHF/6-31G** ab initio
3809 C calculations of diethyl disulfide.
3810 C
3811 C A. Liwo and U. Kozlowska, 11/24/03
3812 C
3813       implicit real*8 (a-h,o-z)
3814       include 'DIMENSIONS'
3815       include 'DIMENSIONS.ZSCOPT'
3816       include 'COMMON.SBRIDGE'
3817       include 'COMMON.CHAIN'
3818       include 'COMMON.DERIV'
3819       include 'COMMON.LOCAL'
3820       include 'COMMON.INTERACT'
3821       include 'COMMON.VAR'
3822       include 'COMMON.IOUNITS'
3823       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3824       itypi=iabs(itype(i))
3825       xi=c(1,nres+i)
3826       yi=c(2,nres+i)
3827       zi=c(3,nres+i)
3828       dxi=dc_norm(1,nres+i)
3829       dyi=dc_norm(2,nres+i)
3830       dzi=dc_norm(3,nres+i)
3831       dsci_inv=dsc_inv(itypi)
3832       itypj=iabs(itype(j))
3833       dscj_inv=dsc_inv(itypj)
3834       xj=c(1,nres+j)-xi
3835       yj=c(2,nres+j)-yi
3836       zj=c(3,nres+j)-zi
3837       dxj=dc_norm(1,nres+j)
3838       dyj=dc_norm(2,nres+j)
3839       dzj=dc_norm(3,nres+j)
3840       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3841       rij=dsqrt(rrij)
3842       erij(1)=xj*rij
3843       erij(2)=yj*rij
3844       erij(3)=zj*rij
3845       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3846       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3847       om12=dxi*dxj+dyi*dyj+dzi*dzj
3848       do k=1,3
3849         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3850         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3851       enddo
3852       rij=1.0d0/rij
3853       deltad=rij-d0cm
3854       deltat1=1.0d0-om1
3855       deltat2=1.0d0+om2
3856       deltat12=om2-om1+2.0d0
3857       cosphi=om12-om1*om2
3858       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3859      &  +akct*deltad*deltat12
3860      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3861 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3862 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3863 c     &  " deltat12",deltat12," eij",eij
3864       ed=2*akcm*deltad+akct*deltat12
3865       pom1=akct*deltad
3866       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3867       eom1=-2*akth*deltat1-pom1-om2*pom2
3868       eom2= 2*akth*deltat2+pom1-om1*pom2
3869       eom12=pom2
3870       do k=1,3
3871         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3872       enddo
3873       do k=1,3
3874         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3875      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3876         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3877      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3878       enddo
3879 C
3880 C Calculate the components of the gradient in DC and X
3881 C
3882       do k=i,j-1
3883         do l=1,3
3884           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3885         enddo
3886       enddo
3887       return
3888       end
3889 C--------------------------------------------------------------------------
3890       subroutine ebond(estr)
3891 c
3892 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3893 c
3894       implicit real*8 (a-h,o-z)
3895       include 'DIMENSIONS'
3896       include 'DIMENSIONS.ZSCOPT'
3897       include 'COMMON.LOCAL'
3898       include 'COMMON.GEO'
3899       include 'COMMON.INTERACT'
3900       include 'COMMON.DERIV'
3901       include 'COMMON.VAR'
3902       include 'COMMON.CHAIN'
3903       include 'COMMON.IOUNITS'
3904       include 'COMMON.NAMES'
3905       include 'COMMON.FFIELD'
3906       include 'COMMON.CONTROL'
3907       logical energy_dec /.false./
3908       double precision u(3),ud(3)
3909       estr=0.0d0
3910       estr1=0.0d0
3911 c      write (iout,*) "distchainmax",distchainmax
3912       do i=nnt+1,nct
3913         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3914 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3915 C          do j=1,3
3916 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3917 C     &      *dc(j,i-1)/vbld(i)
3918 C          enddo
3919 C          if (energy_dec) write(iout,*)
3920 C     &       "estr1",i,vbld(i),distchainmax,
3921 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3922 C        else
3923          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3924         diff = vbld(i)-vbldpDUM
3925 C         write(iout,*) i,diff
3926          else
3927           diff = vbld(i)-vbldp0
3928 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3929          endif
3930           estr=estr+diff*diff
3931           do j=1,3
3932             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3933           enddo
3934 C        endif
3935 C        write (iout,'(a7,i5,4f7.3)')
3936 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3937       enddo
3938       estr=0.5d0*AKP*estr+estr1
3939 c
3940 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3941 c
3942       do i=nnt,nct
3943         iti=iabs(itype(i))
3944         if (iti.ne.10 .and. iti.ne.ntyp1) then
3945           nbi=nbondterm(iti)
3946           if (nbi.eq.1) then
3947             diff=vbld(i+nres)-vbldsc0(1,iti)
3948 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3949 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3950             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3951             do j=1,3
3952               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3953             enddo
3954           else
3955             do j=1,nbi
3956               diff=vbld(i+nres)-vbldsc0(j,iti)
3957               ud(j)=aksc(j,iti)*diff
3958               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3959             enddo
3960             uprod=u(1)
3961             do j=2,nbi
3962               uprod=uprod*u(j)
3963             enddo
3964             usum=0.0d0
3965             usumsqder=0.0d0
3966             do j=1,nbi
3967               uprod1=1.0d0
3968               uprod2=1.0d0
3969               do k=1,nbi
3970                 if (k.ne.j) then
3971                   uprod1=uprod1*u(k)
3972                   uprod2=uprod2*u(k)*u(k)
3973                 endif
3974               enddo
3975               usum=usum+uprod1
3976               usumsqder=usumsqder+ud(j)*uprod2
3977             enddo
3978 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3979 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3980             estr=estr+uprod/usum
3981             do j=1,3
3982              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3983             enddo
3984           endif
3985         endif
3986       enddo
3987       return
3988       end
3989 #ifdef CRYST_THETA
3990 C--------------------------------------------------------------------------
3991       subroutine ebend(etheta,ethetacnstr)
3992 C
3993 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3994 C angles gamma and its derivatives in consecutive thetas and gammas.
3995 C
3996       implicit real*8 (a-h,o-z)
3997       include 'DIMENSIONS'
3998       include 'DIMENSIONS.ZSCOPT'
3999       include 'COMMON.LOCAL'
4000       include 'COMMON.GEO'
4001       include 'COMMON.INTERACT'
4002       include 'COMMON.DERIV'
4003       include 'COMMON.VAR'
4004       include 'COMMON.CHAIN'
4005       include 'COMMON.IOUNITS'
4006       include 'COMMON.NAMES'
4007       include 'COMMON.FFIELD'
4008       include 'COMMON.TORCNSTR'
4009       common /calcthet/ term1,term2,termm,diffak,ratak,
4010      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4011      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4012       double precision y(2),z(2)
4013       delta=0.02d0*pi
4014 c      time11=dexp(-2*time)
4015 c      time12=1.0d0
4016       etheta=0.0D0
4017 c      write (iout,*) "nres",nres
4018 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4019 c      write (iout,*) ithet_start,ithet_end
4020       do i=ithet_start,ithet_end
4021 C        if (itype(i-1).eq.ntyp1) cycle
4022         if (i.le.2) cycle
4023         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4024      &  .or.itype(i).eq.ntyp1) cycle
4025 C Zero the energy function and its derivative at 0 or pi.
4026         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4027         it=itype(i-1)
4028         ichir1=isign(1,itype(i-2))
4029         ichir2=isign(1,itype(i))
4030          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4031          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4032          if (itype(i-1).eq.10) then
4033           itype1=isign(10,itype(i-2))
4034           ichir11=isign(1,itype(i-2))
4035           ichir12=isign(1,itype(i-2))
4036           itype2=isign(10,itype(i))
4037           ichir21=isign(1,itype(i))
4038           ichir22=isign(1,itype(i))
4039          endif
4040          if (i.eq.3) then
4041           y(1)=0.0D0
4042           y(2)=0.0D0
4043           else
4044
4045         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4046 #ifdef OSF
4047           phii=phi(i)
4048 c          icrc=0
4049 c          call proc_proc(phii,icrc)
4050           if (icrc.eq.1) phii=150.0
4051 #else
4052           phii=phi(i)
4053 #endif
4054           y(1)=dcos(phii)
4055           y(2)=dsin(phii)
4056         else
4057           y(1)=0.0D0
4058           y(2)=0.0D0
4059         endif
4060         endif
4061         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4062 #ifdef OSF
4063           phii1=phi(i+1)
4064 c          icrc=0
4065 c          call proc_proc(phii1,icrc)
4066           if (icrc.eq.1) phii1=150.0
4067           phii1=pinorm(phii1)
4068           z(1)=cos(phii1)
4069 #else
4070           phii1=phi(i+1)
4071           z(1)=dcos(phii1)
4072 #endif
4073           z(2)=dsin(phii1)
4074         else
4075           z(1)=0.0D0
4076           z(2)=0.0D0
4077         endif
4078 C Calculate the "mean" value of theta from the part of the distribution
4079 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4080 C In following comments this theta will be referred to as t_c.
4081         thet_pred_mean=0.0d0
4082         do k=1,2
4083             athetk=athet(k,it,ichir1,ichir2)
4084             bthetk=bthet(k,it,ichir1,ichir2)
4085           if (it.eq.10) then
4086              athetk=athet(k,itype1,ichir11,ichir12)
4087              bthetk=bthet(k,itype2,ichir21,ichir22)
4088           endif
4089           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4090         enddo
4091 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4092         dthett=thet_pred_mean*ssd
4093         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4094 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4095 C Derivatives of the "mean" values in gamma1 and gamma2.
4096         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4097      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4098          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4099      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4100          if (it.eq.10) then
4101       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4102      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4103         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4104      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4105          endif
4106         if (theta(i).gt.pi-delta) then
4107           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4108      &         E_tc0)
4109           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4110           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4111           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4112      &        E_theta)
4113           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4114      &        E_tc)
4115         else if (theta(i).lt.delta) then
4116           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4117           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4118           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4119      &        E_theta)
4120           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4121           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4122      &        E_tc)
4123         else
4124           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4125      &        E_theta,E_tc)
4126         endif
4127         etheta=etheta+ethetai
4128 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4129 c     &      'ebend',i,ethetai,theta(i),itype(i)
4130 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4131 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4132         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4133         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4134         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4135 c 1215   continue
4136       enddo
4137       ethetacnstr=0.0d0
4138 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4139       do i=1,ntheta_constr
4140         itheta=itheta_constr(i)
4141         thetiii=theta(itheta)
4142         difi=pinorm(thetiii-theta_constr0(i))
4143         if (difi.gt.theta_drange(i)) then
4144           difi=difi-theta_drange(i)
4145           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4146           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4147      &    +for_thet_constr(i)*difi**3
4148         else if (difi.lt.-drange(i)) then
4149           difi=difi+drange(i)
4150           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4151           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4152      &    +for_thet_constr(i)*difi**3
4153         else
4154           difi=0.0
4155         endif
4156 C       if (energy_dec) then
4157 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4158 C     &    i,itheta,rad2deg*thetiii,
4159 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4160 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4161 C     &    gloc(itheta+nphi-2,icg)
4162 C        endif
4163       enddo
4164 C Ufff.... We've done all this!!!
4165       return
4166       end
4167 C---------------------------------------------------------------------------
4168       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4169      &     E_tc)
4170       implicit real*8 (a-h,o-z)
4171       include 'DIMENSIONS'
4172       include 'COMMON.LOCAL'
4173       include 'COMMON.IOUNITS'
4174       common /calcthet/ term1,term2,termm,diffak,ratak,
4175      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4176      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4177 C Calculate the contributions to both Gaussian lobes.
4178 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4179 C The "polynomial part" of the "standard deviation" of this part of
4180 C the distribution.
4181         sig=polthet(3,it)
4182         do j=2,0,-1
4183           sig=sig*thet_pred_mean+polthet(j,it)
4184         enddo
4185 C Derivative of the "interior part" of the "standard deviation of the"
4186 C gamma-dependent Gaussian lobe in t_c.
4187         sigtc=3*polthet(3,it)
4188         do j=2,1,-1
4189           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4190         enddo
4191         sigtc=sig*sigtc
4192 C Set the parameters of both Gaussian lobes of the distribution.
4193 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4194         fac=sig*sig+sigc0(it)
4195         sigcsq=fac+fac
4196         sigc=1.0D0/sigcsq
4197 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4198         sigsqtc=-4.0D0*sigcsq*sigtc
4199 c       print *,i,sig,sigtc,sigsqtc
4200 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4201         sigtc=-sigtc/(fac*fac)
4202 C Following variable is sigma(t_c)**(-2)
4203         sigcsq=sigcsq*sigcsq
4204         sig0i=sig0(it)
4205         sig0inv=1.0D0/sig0i**2
4206         delthec=thetai-thet_pred_mean
4207         delthe0=thetai-theta0i
4208         term1=-0.5D0*sigcsq*delthec*delthec
4209         term2=-0.5D0*sig0inv*delthe0*delthe0
4210 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4211 C NaNs in taking the logarithm. We extract the largest exponent which is added
4212 C to the energy (this being the log of the distribution) at the end of energy
4213 C term evaluation for this virtual-bond angle.
4214         if (term1.gt.term2) then
4215           termm=term1
4216           term2=dexp(term2-termm)
4217           term1=1.0d0
4218         else
4219           termm=term2
4220           term1=dexp(term1-termm)
4221           term2=1.0d0
4222         endif
4223 C The ratio between the gamma-independent and gamma-dependent lobes of
4224 C the distribution is a Gaussian function of thet_pred_mean too.
4225         diffak=gthet(2,it)-thet_pred_mean
4226         ratak=diffak/gthet(3,it)**2
4227         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4228 C Let's differentiate it in thet_pred_mean NOW.
4229         aktc=ak*ratak
4230 C Now put together the distribution terms to make complete distribution.
4231         termexp=term1+ak*term2
4232         termpre=sigc+ak*sig0i
4233 C Contribution of the bending energy from this theta is just the -log of
4234 C the sum of the contributions from the two lobes and the pre-exponential
4235 C factor. Simple enough, isn't it?
4236         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4237 C NOW the derivatives!!!
4238 C 6/6/97 Take into account the deformation.
4239         E_theta=(delthec*sigcsq*term1
4240      &       +ak*delthe0*sig0inv*term2)/termexp
4241         E_tc=((sigtc+aktc*sig0i)/termpre
4242      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4243      &       aktc*term2)/termexp)
4244       return
4245       end
4246 c-----------------------------------------------------------------------------
4247       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4248       implicit real*8 (a-h,o-z)
4249       include 'DIMENSIONS'
4250       include 'COMMON.LOCAL'
4251       include 'COMMON.IOUNITS'
4252       common /calcthet/ term1,term2,termm,diffak,ratak,
4253      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4254      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4255       delthec=thetai-thet_pred_mean
4256       delthe0=thetai-theta0i
4257 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4258       t3 = thetai-thet_pred_mean
4259       t6 = t3**2
4260       t9 = term1
4261       t12 = t3*sigcsq
4262       t14 = t12+t6*sigsqtc
4263       t16 = 1.0d0
4264       t21 = thetai-theta0i
4265       t23 = t21**2
4266       t26 = term2
4267       t27 = t21*t26
4268       t32 = termexp
4269       t40 = t32**2
4270       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4271      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4272      & *(-t12*t9-ak*sig0inv*t27)
4273       return
4274       end
4275 #else
4276 C--------------------------------------------------------------------------
4277       subroutine ebend(etheta,ethetacnstr)
4278 C
4279 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4280 C angles gamma and its derivatives in consecutive thetas and gammas.
4281 C ab initio-derived potentials from
4282 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4283 C
4284       implicit real*8 (a-h,o-z)
4285       include 'DIMENSIONS'
4286       include 'DIMENSIONS.ZSCOPT'
4287       include 'COMMON.LOCAL'
4288       include 'COMMON.GEO'
4289       include 'COMMON.INTERACT'
4290       include 'COMMON.DERIV'
4291       include 'COMMON.VAR'
4292       include 'COMMON.CHAIN'
4293       include 'COMMON.IOUNITS'
4294       include 'COMMON.NAMES'
4295       include 'COMMON.FFIELD'
4296       include 'COMMON.CONTROL'
4297       include 'COMMON.TORCNSTR'
4298       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4299      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4300      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4301      & sinph1ph2(maxdouble,maxdouble)
4302       logical lprn /.false./, lprn1 /.false./
4303       etheta=0.0D0
4304 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4305       do i=ithet_start,ithet_end
4306 C         if (i.eq.2) cycle
4307 C        if (itype(i-1).eq.ntyp1) cycle
4308         if (i.le.2) cycle
4309         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4310      &  .or.itype(i).eq.ntyp1) cycle
4311         if (iabs(itype(i+1)).eq.20) iblock=2
4312         if (iabs(itype(i+1)).ne.20) iblock=1
4313         dethetai=0.0d0
4314         dephii=0.0d0
4315         dephii1=0.0d0
4316         theti2=0.5d0*theta(i)
4317         ityp2=ithetyp((itype(i-1)))
4318         do k=1,nntheterm
4319           coskt(k)=dcos(k*theti2)
4320           sinkt(k)=dsin(k*theti2)
4321         enddo
4322         if (i.eq.3) then
4323           phii=0.0d0
4324           ityp1=nthetyp+1
4325           do k=1,nsingle
4326             cosph1(k)=0.0d0
4327             sinph1(k)=0.0d0
4328           enddo
4329         else
4330         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4331 #ifdef OSF
4332           phii=phi(i)
4333           if (phii.ne.phii) phii=150.0
4334 #else
4335           phii=phi(i)
4336 #endif
4337           ityp1=ithetyp((itype(i-2)))
4338           do k=1,nsingle
4339             cosph1(k)=dcos(k*phii)
4340             sinph1(k)=dsin(k*phii)
4341           enddo
4342         else
4343           phii=0.0d0
4344 c          ityp1=nthetyp+1
4345           do k=1,nsingle
4346             ityp1=ithetyp((itype(i-2)))
4347             cosph1(k)=0.0d0
4348             sinph1(k)=0.0d0
4349           enddo
4350         endif
4351         endif
4352         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4353 #ifdef OSF
4354           phii1=phi(i+1)
4355           if (phii1.ne.phii1) phii1=150.0
4356           phii1=pinorm(phii1)
4357 #else
4358           phii1=phi(i+1)
4359 #endif
4360           ityp3=ithetyp((itype(i)))
4361           do k=1,nsingle
4362             cosph2(k)=dcos(k*phii1)
4363             sinph2(k)=dsin(k*phii1)
4364           enddo
4365         else
4366           phii1=0.0d0
4367 c          ityp3=nthetyp+1
4368           ityp3=ithetyp((itype(i)))
4369           do k=1,nsingle
4370             cosph2(k)=0.0d0
4371             sinph2(k)=0.0d0
4372           enddo
4373         endif
4374 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4375 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4376 c        call flush(iout)
4377         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4378         do k=1,ndouble
4379           do l=1,k-1
4380             ccl=cosph1(l)*cosph2(k-l)
4381             ssl=sinph1(l)*sinph2(k-l)
4382             scl=sinph1(l)*cosph2(k-l)
4383             csl=cosph1(l)*sinph2(k-l)
4384             cosph1ph2(l,k)=ccl-ssl
4385             cosph1ph2(k,l)=ccl+ssl
4386             sinph1ph2(l,k)=scl+csl
4387             sinph1ph2(k,l)=scl-csl
4388           enddo
4389         enddo
4390         if (lprn) then
4391         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4392      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4393         write (iout,*) "coskt and sinkt"
4394         do k=1,nntheterm
4395           write (iout,*) k,coskt(k),sinkt(k)
4396         enddo
4397         endif
4398         do k=1,ntheterm
4399           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4400           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4401      &      *coskt(k)
4402           if (lprn)
4403      &    write (iout,*) "k",k,"
4404      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4405      &     " ethetai",ethetai
4406         enddo
4407         if (lprn) then
4408         write (iout,*) "cosph and sinph"
4409         do k=1,nsingle
4410           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4411         enddo
4412         write (iout,*) "cosph1ph2 and sinph2ph2"
4413         do k=2,ndouble
4414           do l=1,k-1
4415             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4416      &         sinph1ph2(l,k),sinph1ph2(k,l)
4417           enddo
4418         enddo
4419         write(iout,*) "ethetai",ethetai
4420         endif
4421         do m=1,ntheterm2
4422           do k=1,nsingle
4423             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4424      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4425      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4426      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4427             ethetai=ethetai+sinkt(m)*aux
4428             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4429             dephii=dephii+k*sinkt(m)*(
4430      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4431      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4432             dephii1=dephii1+k*sinkt(m)*(
4433      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4434      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4435             if (lprn)
4436      &      write (iout,*) "m",m," k",k," bbthet",
4437      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4438      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4439      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4440      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4441           enddo
4442         enddo
4443         if (lprn)
4444      &  write(iout,*) "ethetai",ethetai
4445         do m=1,ntheterm3
4446           do k=2,ndouble
4447             do l=1,k-1
4448               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4449      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4450      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4451      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4452               ethetai=ethetai+sinkt(m)*aux
4453               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4454               dephii=dephii+l*sinkt(m)*(
4455      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4456      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4457      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4458      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4459               dephii1=dephii1+(k-l)*sinkt(m)*(
4460      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4461      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4462      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4463      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4464               if (lprn) then
4465               write (iout,*) "m",m," k",k," l",l," ffthet",
4466      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4467      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4468      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4469      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4470      &            " ethetai",ethetai
4471               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4472      &            cosph1ph2(k,l)*sinkt(m),
4473      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4474               endif
4475             enddo
4476           enddo
4477         enddo
4478 10      continue
4479         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4480      &   i,theta(i)*rad2deg,phii*rad2deg,
4481      &   phii1*rad2deg,ethetai
4482         etheta=etheta+ethetai
4483         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4484         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4485 c        gloc(nphi+i-2,icg)=wang*dethetai
4486         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4487       enddo
4488 C now constrains
4489       ethetacnstr=0.0d0
4490 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4491       do i=1,ntheta_constr
4492         itheta=itheta_constr(i)
4493         thetiii=theta(itheta)
4494         difi=pinorm(thetiii-theta_constr0(i))
4495         if (difi.gt.theta_drange(i)) then
4496           difi=difi-theta_drange(i)
4497           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4498           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4499      &    +for_thet_constr(i)*difi**3
4500         else if (difi.lt.-drange(i)) then
4501           difi=difi+drange(i)
4502           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4503           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4504      &    +for_thet_constr(i)*difi**3
4505         else
4506           difi=0.0
4507         endif
4508 C       if (energy_dec) then
4509 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4510 C     &    i,itheta,rad2deg*thetiii,
4511 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4512 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4513 C     &    gloc(itheta+nphi-2,icg)
4514 C        endif
4515       enddo
4516       return
4517       end
4518 #endif
4519 #ifdef CRYST_SC
4520 c-----------------------------------------------------------------------------
4521       subroutine esc(escloc)
4522 C Calculate the local energy of a side chain and its derivatives in the
4523 C corresponding virtual-bond valence angles THETA and the spherical angles
4524 C ALPHA and OMEGA.
4525       implicit real*8 (a-h,o-z)
4526       include 'DIMENSIONS'
4527       include 'DIMENSIONS.ZSCOPT'
4528       include 'COMMON.GEO'
4529       include 'COMMON.LOCAL'
4530       include 'COMMON.VAR'
4531       include 'COMMON.INTERACT'
4532       include 'COMMON.DERIV'
4533       include 'COMMON.CHAIN'
4534       include 'COMMON.IOUNITS'
4535       include 'COMMON.NAMES'
4536       include 'COMMON.FFIELD'
4537       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4538      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4539       common /sccalc/ time11,time12,time112,theti,it,nlobit
4540       delta=0.02d0*pi
4541       escloc=0.0D0
4542 C      write (iout,*) 'ESC'
4543       do i=loc_start,loc_end
4544         it=itype(i)
4545         if (it.eq.ntyp1) cycle
4546         if (it.eq.10) goto 1
4547         nlobit=nlob(iabs(it))
4548 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4549 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4550         theti=theta(i+1)-pipol
4551         x(1)=dtan(theti)
4552         x(2)=alph(i)
4553         x(3)=omeg(i)
4554 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4555
4556         if (x(2).gt.pi-delta) then
4557           xtemp(1)=x(1)
4558           xtemp(2)=pi-delta
4559           xtemp(3)=x(3)
4560           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4561           xtemp(2)=pi
4562           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4563           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4564      &        escloci,dersc(2))
4565           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4566      &        ddersc0(1),dersc(1))
4567           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4568      &        ddersc0(3),dersc(3))
4569           xtemp(2)=pi-delta
4570           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4571           xtemp(2)=pi
4572           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4573           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4574      &            dersc0(2),esclocbi,dersc02)
4575           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4576      &            dersc12,dersc01)
4577           call splinthet(x(2),0.5d0*delta,ss,ssd)
4578           dersc0(1)=dersc01
4579           dersc0(2)=dersc02
4580           dersc0(3)=0.0d0
4581           do k=1,3
4582             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4583           enddo
4584           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4585           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4586      &             esclocbi,ss,ssd
4587           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4588 c         escloci=esclocbi
4589 c         write (iout,*) escloci
4590         else if (x(2).lt.delta) then
4591           xtemp(1)=x(1)
4592           xtemp(2)=delta
4593           xtemp(3)=x(3)
4594           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4595           xtemp(2)=0.0d0
4596           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4597           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4598      &        escloci,dersc(2))
4599           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4600      &        ddersc0(1),dersc(1))
4601           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4602      &        ddersc0(3),dersc(3))
4603           xtemp(2)=delta
4604           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4605           xtemp(2)=0.0d0
4606           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4607           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4608      &            dersc0(2),esclocbi,dersc02)
4609           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4610      &            dersc12,dersc01)
4611           dersc0(1)=dersc01
4612           dersc0(2)=dersc02
4613           dersc0(3)=0.0d0
4614           call splinthet(x(2),0.5d0*delta,ss,ssd)
4615           do k=1,3
4616             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4617           enddo
4618           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4619 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4620 c     &             esclocbi,ss,ssd
4621           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4622 C         write (iout,*) 'i=',i, escloci
4623         else
4624           call enesc(x,escloci,dersc,ddummy,.false.)
4625         endif
4626
4627         escloc=escloc+escloci
4628 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4629             write (iout,'(a6,i5,0pf7.3)')
4630      &     'escloc',i,escloci
4631
4632         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4633      &   wscloc*dersc(1)
4634         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4635         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4636     1   continue
4637       enddo
4638       return
4639       end
4640 C---------------------------------------------------------------------------
4641       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4642       implicit real*8 (a-h,o-z)
4643       include 'DIMENSIONS'
4644       include 'COMMON.GEO'
4645       include 'COMMON.LOCAL'
4646       include 'COMMON.IOUNITS'
4647       common /sccalc/ time11,time12,time112,theti,it,nlobit
4648       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4649       double precision contr(maxlob,-1:1)
4650       logical mixed
4651 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4652         escloc_i=0.0D0
4653         do j=1,3
4654           dersc(j)=0.0D0
4655           if (mixed) ddersc(j)=0.0d0
4656         enddo
4657         x3=x(3)
4658
4659 C Because of periodicity of the dependence of the SC energy in omega we have
4660 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4661 C To avoid underflows, first compute & store the exponents.
4662
4663         do iii=-1,1
4664
4665           x(3)=x3+iii*dwapi
4666
4667           do j=1,nlobit
4668             do k=1,3
4669               z(k)=x(k)-censc(k,j,it)
4670             enddo
4671             do k=1,3
4672               Axk=0.0D0
4673               do l=1,3
4674                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4675               enddo
4676               Ax(k,j,iii)=Axk
4677             enddo
4678             expfac=0.0D0
4679             do k=1,3
4680               expfac=expfac+Ax(k,j,iii)*z(k)
4681             enddo
4682             contr(j,iii)=expfac
4683           enddo ! j
4684
4685         enddo ! iii
4686
4687         x(3)=x3
4688 C As in the case of ebend, we want to avoid underflows in exponentiation and
4689 C subsequent NaNs and INFs in energy calculation.
4690 C Find the largest exponent
4691         emin=contr(1,-1)
4692         do iii=-1,1
4693           do j=1,nlobit
4694             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4695           enddo
4696         enddo
4697         emin=0.5D0*emin
4698 cd      print *,'it=',it,' emin=',emin
4699
4700 C Compute the contribution to SC energy and derivatives
4701         do iii=-1,1
4702
4703           do j=1,nlobit
4704             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4705 cd          print *,'j=',j,' expfac=',expfac
4706             escloc_i=escloc_i+expfac
4707             do k=1,3
4708               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4709             enddo
4710             if (mixed) then
4711               do k=1,3,2
4712                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4713      &            +gaussc(k,2,j,it))*expfac
4714               enddo
4715             endif
4716           enddo
4717
4718         enddo ! iii
4719
4720         dersc(1)=dersc(1)/cos(theti)**2
4721         ddersc(1)=ddersc(1)/cos(theti)**2
4722         ddersc(3)=ddersc(3)
4723
4724         escloci=-(dlog(escloc_i)-emin)
4725         do j=1,3
4726           dersc(j)=dersc(j)/escloc_i
4727         enddo
4728         if (mixed) then
4729           do j=1,3,2
4730             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4731           enddo
4732         endif
4733       return
4734       end
4735 C------------------------------------------------------------------------------
4736       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4737       implicit real*8 (a-h,o-z)
4738       include 'DIMENSIONS'
4739       include 'COMMON.GEO'
4740       include 'COMMON.LOCAL'
4741       include 'COMMON.IOUNITS'
4742       common /sccalc/ time11,time12,time112,theti,it,nlobit
4743       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4744       double precision contr(maxlob)
4745       logical mixed
4746
4747       escloc_i=0.0D0
4748
4749       do j=1,3
4750         dersc(j)=0.0D0
4751       enddo
4752
4753       do j=1,nlobit
4754         do k=1,2
4755           z(k)=x(k)-censc(k,j,it)
4756         enddo
4757         z(3)=dwapi
4758         do k=1,3
4759           Axk=0.0D0
4760           do l=1,3
4761             Axk=Axk+gaussc(l,k,j,it)*z(l)
4762           enddo
4763           Ax(k,j)=Axk
4764         enddo
4765         expfac=0.0D0
4766         do k=1,3
4767           expfac=expfac+Ax(k,j)*z(k)
4768         enddo
4769         contr(j)=expfac
4770       enddo ! j
4771
4772 C As in the case of ebend, we want to avoid underflows in exponentiation and
4773 C subsequent NaNs and INFs in energy calculation.
4774 C Find the largest exponent
4775       emin=contr(1)
4776       do j=1,nlobit
4777         if (emin.gt.contr(j)) emin=contr(j)
4778       enddo
4779       emin=0.5D0*emin
4780
4781 C Compute the contribution to SC energy and derivatives
4782
4783       dersc12=0.0d0
4784       do j=1,nlobit
4785         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4786         escloc_i=escloc_i+expfac
4787         do k=1,2
4788           dersc(k)=dersc(k)+Ax(k,j)*expfac
4789         enddo
4790         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4791      &            +gaussc(1,2,j,it))*expfac
4792         dersc(3)=0.0d0
4793       enddo
4794
4795       dersc(1)=dersc(1)/cos(theti)**2
4796       dersc12=dersc12/cos(theti)**2
4797       escloci=-(dlog(escloc_i)-emin)
4798       do j=1,2
4799         dersc(j)=dersc(j)/escloc_i
4800       enddo
4801       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4802       return
4803       end
4804 #else
4805 c----------------------------------------------------------------------------------
4806       subroutine esc(escloc)
4807 C Calculate the local energy of a side chain and its derivatives in the
4808 C corresponding virtual-bond valence angles THETA and the spherical angles
4809 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4810 C added by Urszula Kozlowska. 07/11/2007
4811 C
4812       implicit real*8 (a-h,o-z)
4813       include 'DIMENSIONS'
4814       include 'DIMENSIONS.ZSCOPT'
4815       include 'COMMON.GEO'
4816       include 'COMMON.LOCAL'
4817       include 'COMMON.VAR'
4818       include 'COMMON.SCROT'
4819       include 'COMMON.INTERACT'
4820       include 'COMMON.DERIV'
4821       include 'COMMON.CHAIN'
4822       include 'COMMON.IOUNITS'
4823       include 'COMMON.NAMES'
4824       include 'COMMON.FFIELD'
4825       include 'COMMON.CONTROL'
4826       include 'COMMON.VECTORS'
4827       double precision x_prime(3),y_prime(3),z_prime(3)
4828      &    , sumene,dsc_i,dp2_i,x(65),
4829      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4830      &    de_dxx,de_dyy,de_dzz,de_dt
4831       double precision s1_t,s1_6_t,s2_t,s2_6_t
4832       double precision
4833      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4834      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4835      & dt_dCi(3),dt_dCi1(3)
4836       common /sccalc/ time11,time12,time112,theti,it,nlobit
4837       delta=0.02d0*pi
4838       escloc=0.0D0
4839       do i=loc_start,loc_end
4840         if (itype(i).eq.ntyp1) cycle
4841         costtab(i+1) =dcos(theta(i+1))
4842         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4843         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4844         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4845         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4846         cosfac=dsqrt(cosfac2)
4847         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4848         sinfac=dsqrt(sinfac2)
4849         it=iabs(itype(i))
4850         if (it.eq.10) goto 1
4851 c
4852 C  Compute the axes of tghe local cartesian coordinates system; store in
4853 c   x_prime, y_prime and z_prime
4854 c
4855         do j=1,3
4856           x_prime(j) = 0.00
4857           y_prime(j) = 0.00
4858           z_prime(j) = 0.00
4859         enddo
4860 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4861 C     &   dc_norm(3,i+nres)
4862         do j = 1,3
4863           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4864           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4865         enddo
4866         do j = 1,3
4867           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4868         enddo
4869 c       write (2,*) "i",i
4870 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4871 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4872 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4873 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4874 c      & " xy",scalar(x_prime(1),y_prime(1)),
4875 c      & " xz",scalar(x_prime(1),z_prime(1)),
4876 c      & " yy",scalar(y_prime(1),y_prime(1)),
4877 c      & " yz",scalar(y_prime(1),z_prime(1)),
4878 c      & " zz",scalar(z_prime(1),z_prime(1))
4879 c
4880 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4881 C to local coordinate system. Store in xx, yy, zz.
4882 c
4883         xx=0.0d0
4884         yy=0.0d0
4885         zz=0.0d0
4886         do j = 1,3
4887           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4888           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4889           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4890         enddo
4891
4892         xxtab(i)=xx
4893         yytab(i)=yy
4894         zztab(i)=zz
4895 C
4896 C Compute the energy of the ith side cbain
4897 C
4898 c        write (2,*) "xx",xx," yy",yy," zz",zz
4899         it=iabs(itype(i))
4900         do j = 1,65
4901           x(j) = sc_parmin(j,it)
4902         enddo
4903 #ifdef CHECK_COORD
4904 Cc diagnostics - remove later
4905         xx1 = dcos(alph(2))
4906         yy1 = dsin(alph(2))*dcos(omeg(2))
4907         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4908         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4909      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4910      &    xx1,yy1,zz1
4911 C,"  --- ", xx_w,yy_w,zz_w
4912 c end diagnostics
4913 #endif
4914         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4915      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4916      &   + x(10)*yy*zz
4917         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4918      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4919      & + x(20)*yy*zz
4920         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4921      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4922      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4923      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4924      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4925      &  +x(40)*xx*yy*zz
4926         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4927      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4928      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4929      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4930      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4931      &  +x(60)*xx*yy*zz
4932         dsc_i   = 0.743d0+x(61)
4933         dp2_i   = 1.9d0+x(62)
4934         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4935      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4936         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4937      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4938         s1=(1+x(63))/(0.1d0 + dscp1)
4939         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4940         s2=(1+x(65))/(0.1d0 + dscp2)
4941         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4942         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4943      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4944 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4945 c     &   sumene4,
4946 c     &   dscp1,dscp2,sumene
4947 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4948         escloc = escloc + sumene
4949 c        write (2,*) "escloc",escloc
4950 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
4951 c     &  zz,xx,yy
4952         if (.not. calc_grad) goto 1
4953 #ifdef DEBUG
4954 C
4955 C This section to check the numerical derivatives of the energy of ith side
4956 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4957 C #define DEBUG in the code to turn it on.
4958 C
4959         write (2,*) "sumene               =",sumene
4960         aincr=1.0d-7
4961         xxsave=xx
4962         xx=xx+aincr
4963         write (2,*) xx,yy,zz
4964         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4965         de_dxx_num=(sumenep-sumene)/aincr
4966         xx=xxsave
4967         write (2,*) "xx+ sumene from enesc=",sumenep
4968         yysave=yy
4969         yy=yy+aincr
4970         write (2,*) xx,yy,zz
4971         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4972         de_dyy_num=(sumenep-sumene)/aincr
4973         yy=yysave
4974         write (2,*) "yy+ sumene from enesc=",sumenep
4975         zzsave=zz
4976         zz=zz+aincr
4977         write (2,*) xx,yy,zz
4978         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4979         de_dzz_num=(sumenep-sumene)/aincr
4980         zz=zzsave
4981         write (2,*) "zz+ sumene from enesc=",sumenep
4982         costsave=cost2tab(i+1)
4983         sintsave=sint2tab(i+1)
4984         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4985         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4986         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4987         de_dt_num=(sumenep-sumene)/aincr
4988         write (2,*) " t+ sumene from enesc=",sumenep
4989         cost2tab(i+1)=costsave
4990         sint2tab(i+1)=sintsave
4991 C End of diagnostics section.
4992 #endif
4993 C
4994 C Compute the gradient of esc
4995 C
4996         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4997         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4998         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4999         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5000         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5001         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5002         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5003         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5004         pom1=(sumene3*sint2tab(i+1)+sumene1)
5005      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5006         pom2=(sumene4*cost2tab(i+1)+sumene2)
5007      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5008         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5009         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5010      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5011      &  +x(40)*yy*zz
5012         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5013         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5014      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5015      &  +x(60)*yy*zz
5016         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5017      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5018      &        +(pom1+pom2)*pom_dx
5019 #ifdef DEBUG
5020         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5021 #endif
5022 C
5023         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5024         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5025      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5026      &  +x(40)*xx*zz
5027         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5028         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5029      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5030      &  +x(59)*zz**2 +x(60)*xx*zz
5031         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5032      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5033      &        +(pom1-pom2)*pom_dy
5034 #ifdef DEBUG
5035         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5036 #endif
5037 C
5038         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5039      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5040      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5041      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5042      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5043      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5044      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5045      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5046 #ifdef DEBUG
5047         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5048 #endif
5049 C
5050         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5051      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5052      &  +pom1*pom_dt1+pom2*pom_dt2
5053 #ifdef DEBUG
5054         write(2,*), "de_dt = ", de_dt,de_dt_num
5055 #endif
5056 c
5057 C
5058        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5059        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5060        cosfac2xx=cosfac2*xx
5061        sinfac2yy=sinfac2*yy
5062        do k = 1,3
5063          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5064      &      vbld_inv(i+1)
5065          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5066      &      vbld_inv(i)
5067          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5068          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5069 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5070 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5071 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5072 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5073          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5074          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5075          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5076          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5077          dZZ_Ci1(k)=0.0d0
5078          dZZ_Ci(k)=0.0d0
5079          do j=1,3
5080            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5081      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5082            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5083      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5084          enddo
5085
5086          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5087          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5088          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5089 c
5090          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5091          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5092        enddo
5093
5094        do k=1,3
5095          dXX_Ctab(k,i)=dXX_Ci(k)
5096          dXX_C1tab(k,i)=dXX_Ci1(k)
5097          dYY_Ctab(k,i)=dYY_Ci(k)
5098          dYY_C1tab(k,i)=dYY_Ci1(k)
5099          dZZ_Ctab(k,i)=dZZ_Ci(k)
5100          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5101          dXX_XYZtab(k,i)=dXX_XYZ(k)
5102          dYY_XYZtab(k,i)=dYY_XYZ(k)
5103          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5104        enddo
5105
5106        do k = 1,3
5107 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5108 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5109 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5110 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5111 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5112 c     &    dt_dci(k)
5113 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5114 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5115          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5116      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5117          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5118      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5119          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5120      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5121        enddo
5122 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5123 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5124
5125 C to check gradient call subroutine check_grad
5126
5127     1 continue
5128       enddo
5129       return
5130       end
5131 #endif
5132 c------------------------------------------------------------------------------
5133       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5134 C
5135 C This procedure calculates two-body contact function g(rij) and its derivative:
5136 C
5137 C           eps0ij                                     !       x < -1
5138 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5139 C            0                                         !       x > 1
5140 C
5141 C where x=(rij-r0ij)/delta
5142 C
5143 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5144 C
5145       implicit none
5146       double precision rij,r0ij,eps0ij,fcont,fprimcont
5147       double precision x,x2,x4,delta
5148 c     delta=0.02D0*r0ij
5149 c      delta=0.2D0*r0ij
5150       x=(rij-r0ij)/delta
5151       if (x.lt.-1.0D0) then
5152         fcont=eps0ij
5153         fprimcont=0.0D0
5154       else if (x.le.1.0D0) then
5155         x2=x*x
5156         x4=x2*x2
5157         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5158         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5159       else
5160         fcont=0.0D0
5161         fprimcont=0.0D0
5162       endif
5163       return
5164       end
5165 c------------------------------------------------------------------------------
5166       subroutine splinthet(theti,delta,ss,ssder)
5167       implicit real*8 (a-h,o-z)
5168       include 'DIMENSIONS'
5169       include 'DIMENSIONS.ZSCOPT'
5170       include 'COMMON.VAR'
5171       include 'COMMON.GEO'
5172       thetup=pi-delta
5173       thetlow=delta
5174       if (theti.gt.pipol) then
5175         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5176       else
5177         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5178         ssder=-ssder
5179       endif
5180       return
5181       end
5182 c------------------------------------------------------------------------------
5183       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5184       implicit none
5185       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5186       double precision ksi,ksi2,ksi3,a1,a2,a3
5187       a1=fprim0*delta/(f1-f0)
5188       a2=3.0d0-2.0d0*a1
5189       a3=a1-2.0d0
5190       ksi=(x-x0)/delta
5191       ksi2=ksi*ksi
5192       ksi3=ksi2*ksi
5193       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5194       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5195       return
5196       end
5197 c------------------------------------------------------------------------------
5198       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5199       implicit none
5200       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5201       double precision ksi,ksi2,ksi3,a1,a2,a3
5202       ksi=(x-x0)/delta
5203       ksi2=ksi*ksi
5204       ksi3=ksi2*ksi
5205       a1=fprim0x*delta
5206       a2=3*(f1x-f0x)-2*fprim0x*delta
5207       a3=fprim0x*delta-2*(f1x-f0x)
5208       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5209       return
5210       end
5211 C-----------------------------------------------------------------------------
5212 #ifdef CRYST_TOR
5213 C-----------------------------------------------------------------------------
5214       subroutine etor(etors,edihcnstr,fact)
5215       implicit real*8 (a-h,o-z)
5216       include 'DIMENSIONS'
5217       include 'DIMENSIONS.ZSCOPT'
5218       include 'COMMON.VAR'
5219       include 'COMMON.GEO'
5220       include 'COMMON.LOCAL'
5221       include 'COMMON.TORSION'
5222       include 'COMMON.INTERACT'
5223       include 'COMMON.DERIV'
5224       include 'COMMON.CHAIN'
5225       include 'COMMON.NAMES'
5226       include 'COMMON.IOUNITS'
5227       include 'COMMON.FFIELD'
5228       include 'COMMON.TORCNSTR'
5229       logical lprn
5230 C Set lprn=.true. for debugging
5231       lprn=.false.
5232 c      lprn=.true.
5233       etors=0.0D0
5234       do i=iphi_start,iphi_end
5235         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5236      &      .or. itype(i).eq.ntyp1) cycle
5237         itori=itortyp(itype(i-2))
5238         itori1=itortyp(itype(i-1))
5239         phii=phi(i)
5240         gloci=0.0D0
5241 C Proline-Proline pair is a special case...
5242         if (itori.eq.3 .and. itori1.eq.3) then
5243           if (phii.gt.-dwapi3) then
5244             cosphi=dcos(3*phii)
5245             fac=1.0D0/(1.0D0-cosphi)
5246             etorsi=v1(1,3,3)*fac
5247             etorsi=etorsi+etorsi
5248             etors=etors+etorsi-v1(1,3,3)
5249             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5250           endif
5251           do j=1,3
5252             v1ij=v1(j+1,itori,itori1)
5253             v2ij=v2(j+1,itori,itori1)
5254             cosphi=dcos(j*phii)
5255             sinphi=dsin(j*phii)
5256             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5257             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5258           enddo
5259         else
5260           do j=1,nterm_old
5261             v1ij=v1(j,itori,itori1)
5262             v2ij=v2(j,itori,itori1)
5263             cosphi=dcos(j*phii)
5264             sinphi=dsin(j*phii)
5265             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5266             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5267           enddo
5268         endif
5269         if (lprn)
5270      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5271      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5272      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5273         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5274 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5275       enddo
5276 ! 6/20/98 - dihedral angle constraints
5277       edihcnstr=0.0d0
5278       do i=1,ndih_constr
5279         itori=idih_constr(i)
5280         phii=phi(itori)
5281         difi=phii-phi0(i)
5282         if (difi.gt.drange(i)) then
5283           difi=difi-drange(i)
5284           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5285           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5286         else if (difi.lt.-drange(i)) then
5287           difi=difi+drange(i)
5288           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5289           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5290         endif
5291 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5292 C     &    i,itori,rad2deg*phii,
5293 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5294       enddo
5295 !      write (iout,*) 'edihcnstr',edihcnstr
5296       return
5297       end
5298 c------------------------------------------------------------------------------
5299 #else
5300       subroutine etor(etors,edihcnstr,fact)
5301       implicit real*8 (a-h,o-z)
5302       include 'DIMENSIONS'
5303       include 'DIMENSIONS.ZSCOPT'
5304       include 'COMMON.VAR'
5305       include 'COMMON.GEO'
5306       include 'COMMON.LOCAL'
5307       include 'COMMON.TORSION'
5308       include 'COMMON.INTERACT'
5309       include 'COMMON.DERIV'
5310       include 'COMMON.CHAIN'
5311       include 'COMMON.NAMES'
5312       include 'COMMON.IOUNITS'
5313       include 'COMMON.FFIELD'
5314       include 'COMMON.TORCNSTR'
5315       logical lprn
5316 C Set lprn=.true. for debugging
5317       lprn=.false.
5318 c      lprn=.true.
5319       etors=0.0D0
5320       do i=iphi_start,iphi_end
5321         if (i.le.2) cycle
5322         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5323      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5324 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5325 C     &       .or. itype(i).eq.ntyp1) cycle
5326         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5327          if (iabs(itype(i)).eq.20) then
5328          iblock=2
5329          else
5330          iblock=1
5331          endif
5332         itori=itortyp(itype(i-2))
5333         itori1=itortyp(itype(i-1))
5334         phii=phi(i)
5335         gloci=0.0D0
5336 C Regular cosine and sine terms
5337         do j=1,nterm(itori,itori1,iblock)
5338           v1ij=v1(j,itori,itori1,iblock)
5339           v2ij=v2(j,itori,itori1,iblock)
5340           cosphi=dcos(j*phii)
5341           sinphi=dsin(j*phii)
5342           etors=etors+v1ij*cosphi+v2ij*sinphi
5343           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5344         enddo
5345 C Lorentz terms
5346 C                         v1
5347 C  E = SUM ----------------------------------- - v1
5348 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5349 C
5350         cosphi=dcos(0.5d0*phii)
5351         sinphi=dsin(0.5d0*phii)
5352         do j=1,nlor(itori,itori1,iblock)
5353           vl1ij=vlor1(j,itori,itori1)
5354           vl2ij=vlor2(j,itori,itori1)
5355           vl3ij=vlor3(j,itori,itori1)
5356           pom=vl2ij*cosphi+vl3ij*sinphi
5357           pom1=1.0d0/(pom*pom+1.0d0)
5358           etors=etors+vl1ij*pom1
5359 c          if (energy_dec) etors_ii=etors_ii+
5360 c     &                vl1ij*pom1
5361           pom=-pom*pom1*pom1
5362           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5363         enddo
5364 C Subtract the constant term
5365         etors=etors-v0(itori,itori1,iblock)
5366         if (lprn)
5367      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5368      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5369      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5370         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5371 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5372  1215   continue
5373       enddo
5374 ! 6/20/98 - dihedral angle constraints
5375       edihcnstr=0.0d0
5376       do i=1,ndih_constr
5377         itori=idih_constr(i)
5378         phii=phi(itori)
5379         difi=pinorm(phii-phi0(i))
5380         edihi=0.0d0
5381         if (difi.gt.drange(i)) then
5382           difi=difi-drange(i)
5383           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5384           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5385           edihi=0.25d0*ftors(i)*difi**4
5386         else if (difi.lt.-drange(i)) then
5387           difi=difi+drange(i)
5388           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5389           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5390           edihi=0.25d0*ftors(i)*difi**4
5391         else
5392           difi=0.0d0
5393         endif
5394         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5395      &    i,itori,rad2deg*phii,
5396      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5397 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5398 c     &    drange(i),edihi
5399 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5400 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5401       enddo
5402 !      write (iout,*) 'edihcnstr',edihcnstr
5403       return
5404       end
5405 c----------------------------------------------------------------------------
5406       subroutine etor_d(etors_d,fact2)
5407 C 6/23/01 Compute double torsional energy
5408       implicit real*8 (a-h,o-z)
5409       include 'DIMENSIONS'
5410       include 'DIMENSIONS.ZSCOPT'
5411       include 'COMMON.VAR'
5412       include 'COMMON.GEO'
5413       include 'COMMON.LOCAL'
5414       include 'COMMON.TORSION'
5415       include 'COMMON.INTERACT'
5416       include 'COMMON.DERIV'
5417       include 'COMMON.CHAIN'
5418       include 'COMMON.NAMES'
5419       include 'COMMON.IOUNITS'
5420       include 'COMMON.FFIELD'
5421       include 'COMMON.TORCNSTR'
5422       logical lprn
5423 C Set lprn=.true. for debugging
5424       lprn=.false.
5425 c     lprn=.true.
5426       etors_d=0.0D0
5427       do i=iphi_start,iphi_end-1
5428         if (i.le.3) cycle
5429 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5430 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5431          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5432      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5433      &  (itype(i+1).eq.ntyp1)) cycle
5434         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5435      &     goto 1215
5436         itori=itortyp(itype(i-2))
5437         itori1=itortyp(itype(i-1))
5438         itori2=itortyp(itype(i))
5439         phii=phi(i)
5440         phii1=phi(i+1)
5441         gloci1=0.0D0
5442         gloci2=0.0D0
5443         iblock=1
5444         if (iabs(itype(i+1)).eq.20) iblock=2
5445 C Regular cosine and sine terms
5446         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5447           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5448           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5449           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5450           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5451           cosphi1=dcos(j*phii)
5452           sinphi1=dsin(j*phii)
5453           cosphi2=dcos(j*phii1)
5454           sinphi2=dsin(j*phii1)
5455           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5456      &     v2cij*cosphi2+v2sij*sinphi2
5457           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5458           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5459         enddo
5460         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5461           do l=1,k-1
5462             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5463             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5464             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5465             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5466             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5467             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5468             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5469             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5470             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5471      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5472             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5473      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5474             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5475      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5476           enddo
5477         enddo
5478         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5479         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5480  1215   continue
5481       enddo
5482       return
5483       end
5484 #endif
5485 c------------------------------------------------------------------------------
5486       subroutine eback_sc_corr(esccor)
5487 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5488 c        conformational states; temporarily implemented as differences
5489 c        between UNRES torsional potentials (dependent on three types of
5490 c        residues) and the torsional potentials dependent on all 20 types
5491 c        of residues computed from AM1 energy surfaces of terminally-blocked
5492 c        amino-acid residues.
5493       implicit real*8 (a-h,o-z)
5494       include 'DIMENSIONS'
5495       include 'DIMENSIONS.ZSCOPT'
5496       include 'COMMON.VAR'
5497       include 'COMMON.GEO'
5498       include 'COMMON.LOCAL'
5499       include 'COMMON.TORSION'
5500       include 'COMMON.SCCOR'
5501       include 'COMMON.INTERACT'
5502       include 'COMMON.DERIV'
5503       include 'COMMON.CHAIN'
5504       include 'COMMON.NAMES'
5505       include 'COMMON.IOUNITS'
5506       include 'COMMON.FFIELD'
5507       include 'COMMON.CONTROL'
5508       logical lprn
5509 C Set lprn=.true. for debugging
5510       lprn=.false.
5511 c      lprn=.true.
5512 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5513       esccor=0.0D0
5514       do i=itau_start,itau_end
5515         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5516         esccor_ii=0.0D0
5517         isccori=isccortyp(itype(i-2))
5518         isccori1=isccortyp(itype(i-1))
5519         phii=phi(i)
5520         do intertyp=1,3 !intertyp
5521 cc Added 09 May 2012 (Adasko)
5522 cc  Intertyp means interaction type of backbone mainchain correlation:
5523 c   1 = SC...Ca...Ca...Ca
5524 c   2 = Ca...Ca...Ca...SC
5525 c   3 = SC...Ca...Ca...SCi
5526         gloci=0.0D0
5527         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5528      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5529      &      (itype(i-1).eq.ntyp1)))
5530      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5531      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5532      &     .or.(itype(i).eq.ntyp1)))
5533      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5534      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5535      &      (itype(i-3).eq.ntyp1)))) cycle
5536         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5537         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5538      & cycle
5539        do j=1,nterm_sccor(isccori,isccori1)
5540           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5541           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5542           cosphi=dcos(j*tauangle(intertyp,i))
5543           sinphi=dsin(j*tauangle(intertyp,i))
5544            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5545            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5546          enddo
5547 C      write (iout,*)"EBACK_SC_COR",esccor,i
5548 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5549 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5550 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5551         if (lprn)
5552      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5553      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5554      &  (v1sccor(j,1,itori,itori1),j=1,6)
5555      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5556 c        gsccor_loc(i-3)=gloci
5557        enddo !intertyp
5558       enddo
5559       return
5560       end
5561 c------------------------------------------------------------------------------
5562       subroutine multibody(ecorr)
5563 C This subroutine calculates multi-body contributions to energy following
5564 C the idea of Skolnick et al. If side chains I and J make a contact and
5565 C at the same time side chains I+1 and J+1 make a contact, an extra
5566 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5567       implicit real*8 (a-h,o-z)
5568       include 'DIMENSIONS'
5569       include 'COMMON.IOUNITS'
5570       include 'COMMON.DERIV'
5571       include 'COMMON.INTERACT'
5572       include 'COMMON.CONTACTS'
5573       double precision gx(3),gx1(3)
5574       logical lprn
5575
5576 C Set lprn=.true. for debugging
5577       lprn=.false.
5578
5579       if (lprn) then
5580         write (iout,'(a)') 'Contact function values:'
5581         do i=nnt,nct-2
5582           write (iout,'(i2,20(1x,i2,f10.5))')
5583      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5584         enddo
5585       endif
5586       ecorr=0.0D0
5587       do i=nnt,nct
5588         do j=1,3
5589           gradcorr(j,i)=0.0D0
5590           gradxorr(j,i)=0.0D0
5591         enddo
5592       enddo
5593       do i=nnt,nct-2
5594
5595         DO ISHIFT = 3,4
5596
5597         i1=i+ishift
5598         num_conti=num_cont(i)
5599         num_conti1=num_cont(i1)
5600         do jj=1,num_conti
5601           j=jcont(jj,i)
5602           do kk=1,num_conti1
5603             j1=jcont(kk,i1)
5604             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5605 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5606 cd   &                   ' ishift=',ishift
5607 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5608 C The system gains extra energy.
5609               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5610             endif   ! j1==j+-ishift
5611           enddo     ! kk
5612         enddo       ! jj
5613
5614         ENDDO ! ISHIFT
5615
5616       enddo         ! i
5617       return
5618       end
5619 c------------------------------------------------------------------------------
5620       double precision function esccorr(i,j,k,l,jj,kk)
5621       implicit real*8 (a-h,o-z)
5622       include 'DIMENSIONS'
5623       include 'COMMON.IOUNITS'
5624       include 'COMMON.DERIV'
5625       include 'COMMON.INTERACT'
5626       include 'COMMON.CONTACTS'
5627       double precision gx(3),gx1(3)
5628       logical lprn
5629       lprn=.false.
5630       eij=facont(jj,i)
5631       ekl=facont(kk,k)
5632 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5633 C Calculate the multi-body contribution to energy.
5634 C Calculate multi-body contributions to the gradient.
5635 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5636 cd   & k,l,(gacont(m,kk,k),m=1,3)
5637       do m=1,3
5638         gx(m) =ekl*gacont(m,jj,i)
5639         gx1(m)=eij*gacont(m,kk,k)
5640         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5641         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5642         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5643         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5644       enddo
5645       do m=i,j-1
5646         do ll=1,3
5647           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5648         enddo
5649       enddo
5650       do m=k,l-1
5651         do ll=1,3
5652           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5653         enddo
5654       enddo
5655       esccorr=-eij*ekl
5656       return
5657       end
5658 c------------------------------------------------------------------------------
5659 #ifdef MPL
5660       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5661       implicit real*8 (a-h,o-z)
5662       include 'DIMENSIONS'
5663       integer dimen1,dimen2,atom,indx
5664       double precision buffer(dimen1,dimen2)
5665       double precision zapas
5666       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5667      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5668      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5669       num_kont=num_cont_hb(atom)
5670       do i=1,num_kont
5671         do k=1,7
5672           do j=1,3
5673             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5674           enddo ! j
5675         enddo ! k
5676         buffer(i,indx+22)=facont_hb(i,atom)
5677         buffer(i,indx+23)=ees0p(i,atom)
5678         buffer(i,indx+24)=ees0m(i,atom)
5679         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5680       enddo ! i
5681       buffer(1,indx+26)=dfloat(num_kont)
5682       return
5683       end
5684 c------------------------------------------------------------------------------
5685       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5686       implicit real*8 (a-h,o-z)
5687       include 'DIMENSIONS'
5688       integer dimen1,dimen2,atom,indx
5689       double precision buffer(dimen1,dimen2)
5690       double precision zapas
5691       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5692      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5693      &         ees0m(ntyp,maxres),
5694      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5695       num_kont=buffer(1,indx+26)
5696       num_kont_old=num_cont_hb(atom)
5697       num_cont_hb(atom)=num_kont+num_kont_old
5698       do i=1,num_kont
5699         ii=i+num_kont_old
5700         do k=1,7
5701           do j=1,3
5702             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5703           enddo ! j
5704         enddo ! k
5705         facont_hb(ii,atom)=buffer(i,indx+22)
5706         ees0p(ii,atom)=buffer(i,indx+23)
5707         ees0m(ii,atom)=buffer(i,indx+24)
5708         jcont_hb(ii,atom)=buffer(i,indx+25)
5709       enddo ! i
5710       return
5711       end
5712 c------------------------------------------------------------------------------
5713 #endif
5714       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5715 C This subroutine calculates multi-body contributions to hydrogen-bonding
5716       implicit real*8 (a-h,o-z)
5717       include 'DIMENSIONS'
5718       include 'DIMENSIONS.ZSCOPT'
5719       include 'COMMON.IOUNITS'
5720 #ifdef MPL
5721       include 'COMMON.INFO'
5722 #endif
5723       include 'COMMON.FFIELD'
5724       include 'COMMON.DERIV'
5725       include 'COMMON.INTERACT'
5726       include 'COMMON.CONTACTS'
5727 #ifdef MPL
5728       parameter (max_cont=maxconts)
5729       parameter (max_dim=2*(8*3+2))
5730       parameter (msglen1=max_cont*max_dim*4)
5731       parameter (msglen2=2*msglen1)
5732       integer source,CorrelType,CorrelID,Error
5733       double precision buffer(max_cont,max_dim)
5734 #endif
5735       double precision gx(3),gx1(3)
5736       logical lprn,ldone
5737
5738 C Set lprn=.true. for debugging
5739       lprn=.false.
5740 #ifdef MPL
5741       n_corr=0
5742       n_corr1=0
5743       if (fgProcs.le.1) goto 30
5744       if (lprn) then
5745         write (iout,'(a)') 'Contact function values:'
5746         do i=nnt,nct-2
5747           write (iout,'(2i3,50(1x,i2,f5.2))')
5748      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5749      &    j=1,num_cont_hb(i))
5750         enddo
5751       endif
5752 C Caution! Following code assumes that electrostatic interactions concerning
5753 C a given atom are split among at most two processors!
5754       CorrelType=477
5755       CorrelID=MyID+1
5756       ldone=.false.
5757       do i=1,max_cont
5758         do j=1,max_dim
5759           buffer(i,j)=0.0D0
5760         enddo
5761       enddo
5762       mm=mod(MyRank,2)
5763 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5764       if (mm) 20,20,10
5765    10 continue
5766 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5767       if (MyRank.gt.0) then
5768 C Send correlation contributions to the preceding processor
5769         msglen=msglen1
5770         nn=num_cont_hb(iatel_s)
5771         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5772 cd      write (iout,*) 'The BUFFER array:'
5773 cd      do i=1,nn
5774 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5775 cd      enddo
5776         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5777           msglen=msglen2
5778             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5779 C Clear the contacts of the atom passed to the neighboring processor
5780         nn=num_cont_hb(iatel_s+1)
5781 cd      do i=1,nn
5782 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5783 cd      enddo
5784             num_cont_hb(iatel_s)=0
5785         endif
5786 cd      write (iout,*) 'Processor ',MyID,MyRank,
5787 cd   & ' is sending correlation contribution to processor',MyID-1,
5788 cd   & ' msglen=',msglen
5789 cd      write (*,*) 'Processor ',MyID,MyRank,
5790 cd   & ' is sending correlation contribution to processor',MyID-1,
5791 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5792         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5793 cd      write (iout,*) 'Processor ',MyID,
5794 cd   & ' has sent correlation contribution to processor',MyID-1,
5795 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5796 cd      write (*,*) 'Processor ',MyID,
5797 cd   & ' has sent correlation contribution to processor',MyID-1,
5798 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5799         msglen=msglen1
5800       endif ! (MyRank.gt.0)
5801       if (ldone) goto 30
5802       ldone=.true.
5803    20 continue
5804 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5805       if (MyRank.lt.fgProcs-1) then
5806 C Receive correlation contributions from the next processor
5807         msglen=msglen1
5808         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5809 cd      write (iout,*) 'Processor',MyID,
5810 cd   & ' is receiving correlation contribution from processor',MyID+1,
5811 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5812 cd      write (*,*) 'Processor',MyID,
5813 cd   & ' is receiving correlation contribution from processor',MyID+1,
5814 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5815         nbytes=-1
5816         do while (nbytes.le.0)
5817           call mp_probe(MyID+1,CorrelType,nbytes)
5818         enddo
5819 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5820         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5821 cd      write (iout,*) 'Processor',MyID,
5822 cd   & ' has received correlation contribution from processor',MyID+1,
5823 cd   & ' msglen=',msglen,' nbytes=',nbytes
5824 cd      write (iout,*) 'The received BUFFER array:'
5825 cd      do i=1,max_cont
5826 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5827 cd      enddo
5828         if (msglen.eq.msglen1) then
5829           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5830         else if (msglen.eq.msglen2)  then
5831           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5832           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5833         else
5834           write (iout,*)
5835      & 'ERROR!!!! message length changed while processing correlations.'
5836           write (*,*)
5837      & 'ERROR!!!! message length changed while processing correlations.'
5838           call mp_stopall(Error)
5839         endif ! msglen.eq.msglen1
5840       endif ! MyRank.lt.fgProcs-1
5841       if (ldone) goto 30
5842       ldone=.true.
5843       goto 10
5844    30 continue
5845 #endif
5846       if (lprn) then
5847         write (iout,'(a)') 'Contact function values:'
5848         do i=nnt,nct-2
5849           write (iout,'(2i3,50(1x,i2,f5.2))')
5850      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5851      &    j=1,num_cont_hb(i))
5852         enddo
5853       endif
5854       ecorr=0.0D0
5855 C Remove the loop below after debugging !!!
5856       do i=nnt,nct
5857         do j=1,3
5858           gradcorr(j,i)=0.0D0
5859           gradxorr(j,i)=0.0D0
5860         enddo
5861       enddo
5862 C Calculate the local-electrostatic correlation terms
5863       do i=iatel_s,iatel_e+1
5864         i1=i+1
5865         num_conti=num_cont_hb(i)
5866         num_conti1=num_cont_hb(i+1)
5867         do jj=1,num_conti
5868           j=jcont_hb(jj,i)
5869           do kk=1,num_conti1
5870             j1=jcont_hb(kk,i1)
5871 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5872 c     &         ' jj=',jj,' kk=',kk
5873             if (j1.eq.j+1 .or. j1.eq.j-1) then
5874 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5875 C The system gains extra energy.
5876               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5877               n_corr=n_corr+1
5878             else if (j1.eq.j) then
5879 C Contacts I-J and I-(J+1) occur simultaneously.
5880 C The system loses extra energy.
5881 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5882             endif
5883           enddo ! kk
5884           do kk=1,num_conti
5885             j1=jcont_hb(kk,i)
5886 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5887 c    &         ' jj=',jj,' kk=',kk
5888             if (j1.eq.j+1) then
5889 C Contacts I-J and (I+1)-J occur simultaneously.
5890 C The system loses extra energy.
5891 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5892             endif ! j1==j+1
5893           enddo ! kk
5894         enddo ! jj
5895       enddo ! i
5896       return
5897       end
5898 c------------------------------------------------------------------------------
5899       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5900      &  n_corr1)
5901 C This subroutine calculates multi-body contributions to hydrogen-bonding
5902       implicit real*8 (a-h,o-z)
5903       include 'DIMENSIONS'
5904       include 'DIMENSIONS.ZSCOPT'
5905       include 'COMMON.IOUNITS'
5906 #ifdef MPL
5907       include 'COMMON.INFO'
5908 #endif
5909       include 'COMMON.FFIELD'
5910       include 'COMMON.DERIV'
5911       include 'COMMON.INTERACT'
5912       include 'COMMON.CONTACTS'
5913 #ifdef MPL
5914       parameter (max_cont=maxconts)
5915       parameter (max_dim=2*(8*3+2))
5916       parameter (msglen1=max_cont*max_dim*4)
5917       parameter (msglen2=2*msglen1)
5918       integer source,CorrelType,CorrelID,Error
5919       double precision buffer(max_cont,max_dim)
5920 #endif
5921       double precision gx(3),gx1(3)
5922       logical lprn,ldone
5923
5924 C Set lprn=.true. for debugging
5925       lprn=.false.
5926       eturn6=0.0d0
5927       ecorr6=0.0d0
5928 #ifdef MPL
5929       n_corr=0
5930       n_corr1=0
5931       if (fgProcs.le.1) goto 30
5932       if (lprn) then
5933         write (iout,'(a)') 'Contact function values:'
5934         do i=nnt,nct-2
5935           write (iout,'(2i3,50(1x,i2,f5.2))')
5936      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5937      &    j=1,num_cont_hb(i))
5938         enddo
5939       endif
5940 C Caution! Following code assumes that electrostatic interactions concerning
5941 C a given atom are split among at most two processors!
5942       CorrelType=477
5943       CorrelID=MyID+1
5944       ldone=.false.
5945       do i=1,max_cont
5946         do j=1,max_dim
5947           buffer(i,j)=0.0D0
5948         enddo
5949       enddo
5950       mm=mod(MyRank,2)
5951 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5952       if (mm) 20,20,10
5953    10 continue
5954 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5955       if (MyRank.gt.0) then
5956 C Send correlation contributions to the preceding processor
5957         msglen=msglen1
5958         nn=num_cont_hb(iatel_s)
5959         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5960 cd      write (iout,*) 'The BUFFER array:'
5961 cd      do i=1,nn
5962 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5963 cd      enddo
5964         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5965           msglen=msglen2
5966             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5967 C Clear the contacts of the atom passed to the neighboring processor
5968         nn=num_cont_hb(iatel_s+1)
5969 cd      do i=1,nn
5970 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5971 cd      enddo
5972             num_cont_hb(iatel_s)=0
5973         endif
5974 cd      write (iout,*) 'Processor ',MyID,MyRank,
5975 cd   & ' is sending correlation contribution to processor',MyID-1,
5976 cd   & ' msglen=',msglen
5977 cd      write (*,*) 'Processor ',MyID,MyRank,
5978 cd   & ' is sending correlation contribution to processor',MyID-1,
5979 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5980         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5981 cd      write (iout,*) 'Processor ',MyID,
5982 cd   & ' has sent correlation contribution to processor',MyID-1,
5983 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5984 cd      write (*,*) 'Processor ',MyID,
5985 cd   & ' has sent correlation contribution to processor',MyID-1,
5986 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5987         msglen=msglen1
5988       endif ! (MyRank.gt.0)
5989       if (ldone) goto 30
5990       ldone=.true.
5991    20 continue
5992 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5993       if (MyRank.lt.fgProcs-1) then
5994 C Receive correlation contributions from the next processor
5995         msglen=msglen1
5996         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5997 cd      write (iout,*) 'Processor',MyID,
5998 cd   & ' is receiving correlation contribution from processor',MyID+1,
5999 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6000 cd      write (*,*) 'Processor',MyID,
6001 cd   & ' is receiving correlation contribution from processor',MyID+1,
6002 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6003         nbytes=-1
6004         do while (nbytes.le.0)
6005           call mp_probe(MyID+1,CorrelType,nbytes)
6006         enddo
6007 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6008         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6009 cd      write (iout,*) 'Processor',MyID,
6010 cd   & ' has received correlation contribution from processor',MyID+1,
6011 cd   & ' msglen=',msglen,' nbytes=',nbytes
6012 cd      write (iout,*) 'The received BUFFER array:'
6013 cd      do i=1,max_cont
6014 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6015 cd      enddo
6016         if (msglen.eq.msglen1) then
6017           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6018         else if (msglen.eq.msglen2)  then
6019           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6020           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6021         else
6022           write (iout,*)
6023      & 'ERROR!!!! message length changed while processing correlations.'
6024           write (*,*)
6025      & 'ERROR!!!! message length changed while processing correlations.'
6026           call mp_stopall(Error)
6027         endif ! msglen.eq.msglen1
6028       endif ! MyRank.lt.fgProcs-1
6029       if (ldone) goto 30
6030       ldone=.true.
6031       goto 10
6032    30 continue
6033 #endif
6034       if (lprn) then
6035         write (iout,'(a)') 'Contact function values:'
6036         do i=nnt,nct-2
6037           write (iout,'(2i3,50(1x,i2,f5.2))')
6038      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6039      &    j=1,num_cont_hb(i))
6040         enddo
6041       endif
6042       ecorr=0.0D0
6043       ecorr5=0.0d0
6044       ecorr6=0.0d0
6045 C Remove the loop below after debugging !!!
6046       do i=nnt,nct
6047         do j=1,3
6048           gradcorr(j,i)=0.0D0
6049           gradxorr(j,i)=0.0D0
6050         enddo
6051       enddo
6052 C Calculate the dipole-dipole interaction energies
6053       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6054       do i=iatel_s,iatel_e+1
6055         num_conti=num_cont_hb(i)
6056         do jj=1,num_conti
6057           j=jcont_hb(jj,i)
6058           call dipole(i,j,jj)
6059         enddo
6060       enddo
6061       endif
6062 C Calculate the local-electrostatic correlation terms
6063       do i=iatel_s,iatel_e+1
6064         i1=i+1
6065         num_conti=num_cont_hb(i)
6066         num_conti1=num_cont_hb(i+1)
6067         do jj=1,num_conti
6068           j=jcont_hb(jj,i)
6069           do kk=1,num_conti1
6070             j1=jcont_hb(kk,i1)
6071 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6072 c     &         ' jj=',jj,' kk=',kk
6073             if (j1.eq.j+1 .or. j1.eq.j-1) then
6074 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6075 C The system gains extra energy.
6076               n_corr=n_corr+1
6077               sqd1=dsqrt(d_cont(jj,i))
6078               sqd2=dsqrt(d_cont(kk,i1))
6079               sred_geom = sqd1*sqd2
6080               IF (sred_geom.lt.cutoff_corr) THEN
6081                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6082      &            ekont,fprimcont)
6083 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6084 c     &         ' jj=',jj,' kk=',kk
6085                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6086                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6087                 do l=1,3
6088                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6089                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6090                 enddo
6091                 n_corr1=n_corr1+1
6092 cd               write (iout,*) 'sred_geom=',sred_geom,
6093 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6094                 call calc_eello(i,j,i+1,j1,jj,kk)
6095                 if (wcorr4.gt.0.0d0)
6096      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6097                 if (wcorr5.gt.0.0d0)
6098      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6099 c                print *,"wcorr5",ecorr5
6100 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6101 cd                write(2,*)'ijkl',i,j,i+1,j1
6102                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6103      &               .or. wturn6.eq.0.0d0))then
6104 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6105                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6106 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6107 cd     &            'ecorr6=',ecorr6
6108 cd                write (iout,'(4e15.5)') sred_geom,
6109 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6110 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6111 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6112                 else if (wturn6.gt.0.0d0
6113      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6114 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6115                   eturn6=eturn6+eello_turn6(i,jj,kk)
6116 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6117                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6118                    eturn6=0.0d0
6119                    ecorr6=0.0d0
6120                 endif
6121
6122               ENDIF
6123 1111          continue
6124             else if (j1.eq.j) then
6125 C Contacts I-J and I-(J+1) occur simultaneously.
6126 C The system loses extra energy.
6127 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6128             endif
6129           enddo ! kk
6130           do kk=1,num_conti
6131             j1=jcont_hb(kk,i)
6132 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6133 c    &         ' jj=',jj,' kk=',kk
6134             if (j1.eq.j+1) then
6135 C Contacts I-J and (I+1)-J occur simultaneously.
6136 C The system loses extra energy.
6137 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6138             endif ! j1==j+1
6139           enddo ! kk
6140         enddo ! jj
6141       enddo ! i
6142       write (iout,*) "eturn6",eturn6,ecorr6
6143       return
6144       end
6145 c------------------------------------------------------------------------------
6146       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6147       implicit real*8 (a-h,o-z)
6148       include 'DIMENSIONS'
6149       include 'COMMON.IOUNITS'
6150       include 'COMMON.DERIV'
6151       include 'COMMON.INTERACT'
6152       include 'COMMON.CONTACTS'
6153       include 'COMMON.CONTROL'
6154       include 'COMMON.SHIELD'
6155       double precision gx(3),gx1(3)
6156       logical lprn
6157       lprn=.false.
6158       eij=facont_hb(jj,i)
6159       ekl=facont_hb(kk,k)
6160       ees0pij=ees0p(jj,i)
6161       ees0pkl=ees0p(kk,k)
6162       ees0mij=ees0m(jj,i)
6163       ees0mkl=ees0m(kk,k)
6164       ekont=eij*ekl
6165       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6166 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6167 C Following 4 lines for diagnostics.
6168 cd    ees0pkl=0.0D0
6169 cd    ees0pij=1.0D0
6170 cd    ees0mkl=0.0D0
6171 cd    ees0mij=1.0D0
6172 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6173 c    &   ' and',k,l
6174 c     write (iout,*)'Contacts have occurred for peptide groups',
6175 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6176 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6177 C Calculate the multi-body contribution to energy.
6178 C      ecorr=ecorr+ekont*ees
6179       if (calc_grad) then
6180 C Calculate multi-body contributions to the gradient.
6181       do ll=1,3
6182         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6183         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6184      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6185      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6186         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6187      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6188      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6189         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6190         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6191      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6192      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6193         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6194      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6195      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6196       enddo
6197       do m=i+1,j-1
6198         do ll=1,3
6199           gradcorr(ll,m)=gradcorr(ll,m)+
6200      &     ees*ekl*gacont_hbr(ll,jj,i)-
6201      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6202      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6203         enddo
6204       enddo
6205       do m=k+1,l-1
6206         do ll=1,3
6207           gradcorr(ll,m)=gradcorr(ll,m)+
6208      &     ees*eij*gacont_hbr(ll,kk,k)-
6209      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6210      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6211         enddo
6212       enddo
6213       if (shield_mode.gt.0) then
6214        j=ees0plist(jj,i)
6215        l=ees0plist(kk,k)
6216 C        print *,i,j,fac_shield(i),fac_shield(j),
6217 C     &fac_shield(k),fac_shield(l)
6218         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6219      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6220           do ilist=1,ishield_list(i)
6221            iresshield=shield_list(ilist,i)
6222            do m=1,3
6223            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6224 C     &      *2.0
6225            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6226      &              rlocshield
6227      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6228             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6229      &+rlocshield
6230            enddo
6231           enddo
6232           do ilist=1,ishield_list(j)
6233            iresshield=shield_list(ilist,j)
6234            do m=1,3
6235            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6236 C     &     *2.0
6237            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6238      &              rlocshield
6239      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6240            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6241      &     +rlocshield
6242            enddo
6243           enddo
6244           do ilist=1,ishield_list(k)
6245            iresshield=shield_list(ilist,k)
6246            do m=1,3
6247            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6248 C     &     *2.0
6249            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6250      &              rlocshield
6251      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6252            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6253      &     +rlocshield
6254            enddo
6255           enddo
6256           do ilist=1,ishield_list(l)
6257            iresshield=shield_list(ilist,l)
6258            do m=1,3
6259            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6260 C     &     *2.0
6261            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6262      &              rlocshield
6263      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6264            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6265      &     +rlocshield
6266            enddo
6267           enddo
6268 C          print *,gshieldx(m,iresshield)
6269           do m=1,3
6270             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6271      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6272             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6273      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6274             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6275      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6276             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6277      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6278
6279             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6280      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6281             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6282      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6283             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6284      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6285             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6286      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6287
6288            enddo
6289       endif
6290       endif
6291       endif
6292       ehbcorr=ekont*ees
6293       return
6294       end
6295 C---------------------------------------------------------------------------
6296       subroutine dipole(i,j,jj)
6297       implicit real*8 (a-h,o-z)
6298       include 'DIMENSIONS'
6299       include 'DIMENSIONS.ZSCOPT'
6300       include 'COMMON.IOUNITS'
6301       include 'COMMON.CHAIN'
6302       include 'COMMON.FFIELD'
6303       include 'COMMON.DERIV'
6304       include 'COMMON.INTERACT'
6305       include 'COMMON.CONTACTS'
6306       include 'COMMON.TORSION'
6307       include 'COMMON.VAR'
6308       include 'COMMON.GEO'
6309       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6310      &  auxmat(2,2)
6311       iti1 = itortyp(itype(i+1))
6312       if (j.lt.nres-1) then
6313         if (itype(j).le.ntyp) then
6314           itj1 = itortyp(itype(j+1))
6315         else
6316           itj=ntortyp+1
6317         endif
6318       else
6319         itj1=ntortyp+1
6320       endif
6321       do iii=1,2
6322         dipi(iii,1)=Ub2(iii,i)
6323         dipderi(iii)=Ub2der(iii,i)
6324         dipi(iii,2)=b1(iii,iti1)
6325         dipj(iii,1)=Ub2(iii,j)
6326         dipderj(iii)=Ub2der(iii,j)
6327         dipj(iii,2)=b1(iii,itj1)
6328       enddo
6329       kkk=0
6330       do iii=1,2
6331         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6332         do jjj=1,2
6333           kkk=kkk+1
6334           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6335         enddo
6336       enddo
6337       if (.not.calc_grad) return
6338       do kkk=1,5
6339         do lll=1,3
6340           mmm=0
6341           do iii=1,2
6342             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6343      &        auxvec(1))
6344             do jjj=1,2
6345               mmm=mmm+1
6346               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6347             enddo
6348           enddo
6349         enddo
6350       enddo
6351       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6352       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6353       do iii=1,2
6354         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6355       enddo
6356       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6357       do iii=1,2
6358         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6359       enddo
6360       return
6361       end
6362 C---------------------------------------------------------------------------
6363       subroutine calc_eello(i,j,k,l,jj,kk)
6364 C
6365 C This subroutine computes matrices and vectors needed to calculate
6366 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6367 C
6368       implicit real*8 (a-h,o-z)
6369       include 'DIMENSIONS'
6370       include 'DIMENSIONS.ZSCOPT'
6371       include 'COMMON.IOUNITS'
6372       include 'COMMON.CHAIN'
6373       include 'COMMON.DERIV'
6374       include 'COMMON.INTERACT'
6375       include 'COMMON.CONTACTS'
6376       include 'COMMON.TORSION'
6377       include 'COMMON.VAR'
6378       include 'COMMON.GEO'
6379       include 'COMMON.FFIELD'
6380       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6381      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6382       logical lprn
6383       common /kutas/ lprn
6384 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6385 cd     & ' jj=',jj,' kk=',kk
6386 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6387       do iii=1,2
6388         do jjj=1,2
6389           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6390           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6391         enddo
6392       enddo
6393       call transpose2(aa1(1,1),aa1t(1,1))
6394       call transpose2(aa2(1,1),aa2t(1,1))
6395       do kkk=1,5
6396         do lll=1,3
6397           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6398      &      aa1tder(1,1,lll,kkk))
6399           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6400      &      aa2tder(1,1,lll,kkk))
6401         enddo
6402       enddo
6403       if (l.eq.j+1) then
6404 C parallel orientation of the two CA-CA-CA frames.
6405         if (i.gt.1 .and. itype(i).le.ntyp) then
6406           iti=itortyp(itype(i))
6407         else
6408           iti=ntortyp+1
6409         endif
6410         itk1=itortyp(itype(k+1))
6411         itj=itortyp(itype(j))
6412         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6413           itl1=itortyp(itype(l+1))
6414         else
6415           itl1=ntortyp+1
6416         endif
6417 C A1 kernel(j+1) A2T
6418 cd        do iii=1,2
6419 cd          write (iout,'(3f10.5,5x,3f10.5)')
6420 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6421 cd        enddo
6422         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6423      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6424      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6425 C Following matrices are needed only for 6-th order cumulants
6426         IF (wcorr6.gt.0.0d0) THEN
6427         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6428      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6429      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6430         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6431      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6432      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6433      &   ADtEAderx(1,1,1,1,1,1))
6434         lprn=.false.
6435         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6436      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6437      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6438      &   ADtEA1derx(1,1,1,1,1,1))
6439         ENDIF
6440 C End 6-th order cumulants
6441 cd        lprn=.false.
6442 cd        if (lprn) then
6443 cd        write (2,*) 'In calc_eello6'
6444 cd        do iii=1,2
6445 cd          write (2,*) 'iii=',iii
6446 cd          do kkk=1,5
6447 cd            write (2,*) 'kkk=',kkk
6448 cd            do jjj=1,2
6449 cd              write (2,'(3(2f10.5),5x)')
6450 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6451 cd            enddo
6452 cd          enddo
6453 cd        enddo
6454 cd        endif
6455         call transpose2(EUgder(1,1,k),auxmat(1,1))
6456         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6457         call transpose2(EUg(1,1,k),auxmat(1,1))
6458         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6459         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6460         do iii=1,2
6461           do kkk=1,5
6462             do lll=1,3
6463               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6464      &          EAEAderx(1,1,lll,kkk,iii,1))
6465             enddo
6466           enddo
6467         enddo
6468 C A1T kernel(i+1) A2
6469         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6470      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6471      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6472 C Following matrices are needed only for 6-th order cumulants
6473         IF (wcorr6.gt.0.0d0) THEN
6474         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6475      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6476      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6477         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6478      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6479      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6480      &   ADtEAderx(1,1,1,1,1,2))
6481         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6482      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6483      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6484      &   ADtEA1derx(1,1,1,1,1,2))
6485         ENDIF
6486 C End 6-th order cumulants
6487         call transpose2(EUgder(1,1,l),auxmat(1,1))
6488         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6489         call transpose2(EUg(1,1,l),auxmat(1,1))
6490         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6491         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6492         do iii=1,2
6493           do kkk=1,5
6494             do lll=1,3
6495               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6496      &          EAEAderx(1,1,lll,kkk,iii,2))
6497             enddo
6498           enddo
6499         enddo
6500 C AEAb1 and AEAb2
6501 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6502 C They are needed only when the fifth- or the sixth-order cumulants are
6503 C indluded.
6504         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6505         call transpose2(AEA(1,1,1),auxmat(1,1))
6506         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6507         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6508         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6509         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6510         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6511         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6512         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6513         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6514         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6515         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6516         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6517         call transpose2(AEA(1,1,2),auxmat(1,1))
6518         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6519         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6520         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6521         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6522         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6523         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6524         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6525         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6526         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6527         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6528         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6529 C Calculate the Cartesian derivatives of the vectors.
6530         do iii=1,2
6531           do kkk=1,5
6532             do lll=1,3
6533               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6534               call matvec2(auxmat(1,1),b1(1,iti),
6535      &          AEAb1derx(1,lll,kkk,iii,1,1))
6536               call matvec2(auxmat(1,1),Ub2(1,i),
6537      &          AEAb2derx(1,lll,kkk,iii,1,1))
6538               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6539      &          AEAb1derx(1,lll,kkk,iii,2,1))
6540               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6541      &          AEAb2derx(1,lll,kkk,iii,2,1))
6542               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6543               call matvec2(auxmat(1,1),b1(1,itj),
6544      &          AEAb1derx(1,lll,kkk,iii,1,2))
6545               call matvec2(auxmat(1,1),Ub2(1,j),
6546      &          AEAb2derx(1,lll,kkk,iii,1,2))
6547               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6548      &          AEAb1derx(1,lll,kkk,iii,2,2))
6549               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6550      &          AEAb2derx(1,lll,kkk,iii,2,2))
6551             enddo
6552           enddo
6553         enddo
6554         ENDIF
6555 C End vectors
6556       else
6557 C Antiparallel orientation of the two CA-CA-CA frames.
6558         if (i.gt.1 .and. itype(i).le.ntyp) then
6559           iti=itortyp(itype(i))
6560         else
6561           iti=ntortyp+1
6562         endif
6563         itk1=itortyp(itype(k+1))
6564         itl=itortyp(itype(l))
6565         itj=itortyp(itype(j))
6566         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6567           itj1=itortyp(itype(j+1))
6568         else
6569           itj1=ntortyp+1
6570         endif
6571 C A2 kernel(j-1)T A1T
6572         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6573      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6574      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6575 C Following matrices are needed only for 6-th order cumulants
6576         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6577      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6578         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6579      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6580      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6581         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6582      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6583      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6584      &   ADtEAderx(1,1,1,1,1,1))
6585         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6586      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6587      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6588      &   ADtEA1derx(1,1,1,1,1,1))
6589         ENDIF
6590 C End 6-th order cumulants
6591         call transpose2(EUgder(1,1,k),auxmat(1,1))
6592         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6593         call transpose2(EUg(1,1,k),auxmat(1,1))
6594         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6595         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6596         do iii=1,2
6597           do kkk=1,5
6598             do lll=1,3
6599               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6600      &          EAEAderx(1,1,lll,kkk,iii,1))
6601             enddo
6602           enddo
6603         enddo
6604 C A2T kernel(i+1)T A1
6605         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6606      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6607      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6608 C Following matrices are needed only for 6-th order cumulants
6609         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6610      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6611         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6612      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6613      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6614         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6615      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6616      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6617      &   ADtEAderx(1,1,1,1,1,2))
6618         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6619      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6620      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6621      &   ADtEA1derx(1,1,1,1,1,2))
6622         ENDIF
6623 C End 6-th order cumulants
6624         call transpose2(EUgder(1,1,j),auxmat(1,1))
6625         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6626         call transpose2(EUg(1,1,j),auxmat(1,1))
6627         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6628         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6629         do iii=1,2
6630           do kkk=1,5
6631             do lll=1,3
6632               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6633      &          EAEAderx(1,1,lll,kkk,iii,2))
6634             enddo
6635           enddo
6636         enddo
6637 C AEAb1 and AEAb2
6638 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6639 C They are needed only when the fifth- or the sixth-order cumulants are
6640 C indluded.
6641         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6642      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6643         call transpose2(AEA(1,1,1),auxmat(1,1))
6644         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6645         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6646         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6647         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6648         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6649         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6650         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6651         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6652         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6653         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6654         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6655         call transpose2(AEA(1,1,2),auxmat(1,1))
6656         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6657         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6658         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6659         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6660         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6661         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6662         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6663         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6664         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6665         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6666         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6667 C Calculate the Cartesian derivatives of the vectors.
6668         do iii=1,2
6669           do kkk=1,5
6670             do lll=1,3
6671               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6672               call matvec2(auxmat(1,1),b1(1,iti),
6673      &          AEAb1derx(1,lll,kkk,iii,1,1))
6674               call matvec2(auxmat(1,1),Ub2(1,i),
6675      &          AEAb2derx(1,lll,kkk,iii,1,1))
6676               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6677      &          AEAb1derx(1,lll,kkk,iii,2,1))
6678               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6679      &          AEAb2derx(1,lll,kkk,iii,2,1))
6680               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6681               call matvec2(auxmat(1,1),b1(1,itl),
6682      &          AEAb1derx(1,lll,kkk,iii,1,2))
6683               call matvec2(auxmat(1,1),Ub2(1,l),
6684      &          AEAb2derx(1,lll,kkk,iii,1,2))
6685               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6686      &          AEAb1derx(1,lll,kkk,iii,2,2))
6687               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6688      &          AEAb2derx(1,lll,kkk,iii,2,2))
6689             enddo
6690           enddo
6691         enddo
6692         ENDIF
6693 C End vectors
6694       endif
6695       return
6696       end
6697 C---------------------------------------------------------------------------
6698       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6699      &  KK,KKderg,AKA,AKAderg,AKAderx)
6700       implicit none
6701       integer nderg
6702       logical transp
6703       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6704      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6705      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6706       integer iii,kkk,lll
6707       integer jjj,mmm
6708       logical lprn
6709       common /kutas/ lprn
6710       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6711       do iii=1,nderg
6712         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6713      &    AKAderg(1,1,iii))
6714       enddo
6715 cd      if (lprn) write (2,*) 'In kernel'
6716       do kkk=1,5
6717 cd        if (lprn) write (2,*) 'kkk=',kkk
6718         do lll=1,3
6719           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6720      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6721 cd          if (lprn) then
6722 cd            write (2,*) 'lll=',lll
6723 cd            write (2,*) 'iii=1'
6724 cd            do jjj=1,2
6725 cd              write (2,'(3(2f10.5),5x)')
6726 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6727 cd            enddo
6728 cd          endif
6729           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6730      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6731 cd          if (lprn) then
6732 cd            write (2,*) 'lll=',lll
6733 cd            write (2,*) 'iii=2'
6734 cd            do jjj=1,2
6735 cd              write (2,'(3(2f10.5),5x)')
6736 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6737 cd            enddo
6738 cd          endif
6739         enddo
6740       enddo
6741       return
6742       end
6743 C---------------------------------------------------------------------------
6744       double precision function eello4(i,j,k,l,jj,kk)
6745       implicit real*8 (a-h,o-z)
6746       include 'DIMENSIONS'
6747       include 'DIMENSIONS.ZSCOPT'
6748       include 'COMMON.IOUNITS'
6749       include 'COMMON.CHAIN'
6750       include 'COMMON.DERIV'
6751       include 'COMMON.INTERACT'
6752       include 'COMMON.CONTACTS'
6753       include 'COMMON.TORSION'
6754       include 'COMMON.VAR'
6755       include 'COMMON.GEO'
6756       double precision pizda(2,2),ggg1(3),ggg2(3)
6757 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6758 cd        eello4=0.0d0
6759 cd        return
6760 cd      endif
6761 cd      print *,'eello4:',i,j,k,l,jj,kk
6762 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6763 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6764 cold      eij=facont_hb(jj,i)
6765 cold      ekl=facont_hb(kk,k)
6766 cold      ekont=eij*ekl
6767       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6768       if (calc_grad) then
6769 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6770       gcorr_loc(k-1)=gcorr_loc(k-1)
6771      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6772       if (l.eq.j+1) then
6773         gcorr_loc(l-1)=gcorr_loc(l-1)
6774      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6775       else
6776         gcorr_loc(j-1)=gcorr_loc(j-1)
6777      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6778       endif
6779       do iii=1,2
6780         do kkk=1,5
6781           do lll=1,3
6782             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6783      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6784 cd            derx(lll,kkk,iii)=0.0d0
6785           enddo
6786         enddo
6787       enddo
6788 cd      gcorr_loc(l-1)=0.0d0
6789 cd      gcorr_loc(j-1)=0.0d0
6790 cd      gcorr_loc(k-1)=0.0d0
6791 cd      eel4=1.0d0
6792 cd      write (iout,*)'Contacts have occurred for peptide groups',
6793 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6794 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6795       if (j.lt.nres-1) then
6796         j1=j+1
6797         j2=j-1
6798       else
6799         j1=j-1
6800         j2=j-2
6801       endif
6802       if (l.lt.nres-1) then
6803         l1=l+1
6804         l2=l-1
6805       else
6806         l1=l-1
6807         l2=l-2
6808       endif
6809       do ll=1,3
6810 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6811         ggg1(ll)=eel4*g_contij(ll,1)
6812         ggg2(ll)=eel4*g_contij(ll,2)
6813         ghalf=0.5d0*ggg1(ll)
6814 cd        ghalf=0.0d0
6815         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6816         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6817         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6818         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6819 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6820         ghalf=0.5d0*ggg2(ll)
6821 cd        ghalf=0.0d0
6822         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6823         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6824         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6825         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6826       enddo
6827 cd      goto 1112
6828       do m=i+1,j-1
6829         do ll=1,3
6830 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6831           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6832         enddo
6833       enddo
6834       do m=k+1,l-1
6835         do ll=1,3
6836 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6837           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6838         enddo
6839       enddo
6840 1112  continue
6841       do m=i+2,j2
6842         do ll=1,3
6843           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6844         enddo
6845       enddo
6846       do m=k+2,l2
6847         do ll=1,3
6848           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6849         enddo
6850       enddo
6851 cd      do iii=1,nres-3
6852 cd        write (2,*) iii,gcorr_loc(iii)
6853 cd      enddo
6854       endif
6855       eello4=ekont*eel4
6856 cd      write (2,*) 'ekont',ekont
6857 cd      write (iout,*) 'eello4',ekont*eel4
6858       return
6859       end
6860 C---------------------------------------------------------------------------
6861       double precision function eello5(i,j,k,l,jj,kk)
6862       implicit real*8 (a-h,o-z)
6863       include 'DIMENSIONS'
6864       include 'DIMENSIONS.ZSCOPT'
6865       include 'COMMON.IOUNITS'
6866       include 'COMMON.CHAIN'
6867       include 'COMMON.DERIV'
6868       include 'COMMON.INTERACT'
6869       include 'COMMON.CONTACTS'
6870       include 'COMMON.TORSION'
6871       include 'COMMON.VAR'
6872       include 'COMMON.GEO'
6873       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6874       double precision ggg1(3),ggg2(3)
6875 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6876 C                                                                              C
6877 C                            Parallel chains                                   C
6878 C                                                                              C
6879 C          o             o                   o             o                   C
6880 C         /l\           / \             \   / \           / \   /              C
6881 C        /   \         /   \             \ /   \         /   \ /               C
6882 C       j| o |l1       | o |              o| o |         | o |o                C
6883 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6884 C      \i/   \         /   \ /             /   \         /   \                 C
6885 C       o    k1             o                                                  C
6886 C         (I)          (II)                (III)          (IV)                 C
6887 C                                                                              C
6888 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6889 C                                                                              C
6890 C                            Antiparallel chains                               C
6891 C                                                                              C
6892 C          o             o                   o             o                   C
6893 C         /j\           / \             \   / \           / \   /              C
6894 C        /   \         /   \             \ /   \         /   \ /               C
6895 C      j1| o |l        | o |              o| o |         | o |o                C
6896 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6897 C      \i/   \         /   \ /             /   \         /   \                 C
6898 C       o     k1            o                                                  C
6899 C         (I)          (II)                (III)          (IV)                 C
6900 C                                                                              C
6901 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6902 C                                                                              C
6903 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6904 C                                                                              C
6905 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6906 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6907 cd        eello5=0.0d0
6908 cd        return
6909 cd      endif
6910 cd      write (iout,*)
6911 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6912 cd     &   ' and',k,l
6913       itk=itortyp(itype(k))
6914       itl=itortyp(itype(l))
6915       itj=itortyp(itype(j))
6916       eello5_1=0.0d0
6917       eello5_2=0.0d0
6918       eello5_3=0.0d0
6919       eello5_4=0.0d0
6920 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6921 cd     &   eel5_3_num,eel5_4_num)
6922       do iii=1,2
6923         do kkk=1,5
6924           do lll=1,3
6925             derx(lll,kkk,iii)=0.0d0
6926           enddo
6927         enddo
6928       enddo
6929 cd      eij=facont_hb(jj,i)
6930 cd      ekl=facont_hb(kk,k)
6931 cd      ekont=eij*ekl
6932 cd      write (iout,*)'Contacts have occurred for peptide groups',
6933 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6934 cd      goto 1111
6935 C Contribution from the graph I.
6936 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6937 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6938       call transpose2(EUg(1,1,k),auxmat(1,1))
6939       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6940       vv(1)=pizda(1,1)-pizda(2,2)
6941       vv(2)=pizda(1,2)+pizda(2,1)
6942       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6943      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6944       if (calc_grad) then
6945 C Explicit gradient in virtual-dihedral angles.
6946       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6947      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6948      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6949       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6950       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6951       vv(1)=pizda(1,1)-pizda(2,2)
6952       vv(2)=pizda(1,2)+pizda(2,1)
6953       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6954      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6955      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6956       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6957       vv(1)=pizda(1,1)-pizda(2,2)
6958       vv(2)=pizda(1,2)+pizda(2,1)
6959       if (l.eq.j+1) then
6960         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6961      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6962      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6963       else
6964         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6965      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6966      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6967       endif
6968 C Cartesian gradient
6969       do iii=1,2
6970         do kkk=1,5
6971           do lll=1,3
6972             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6973      &        pizda(1,1))
6974             vv(1)=pizda(1,1)-pizda(2,2)
6975             vv(2)=pizda(1,2)+pizda(2,1)
6976             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6977      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6978      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6979           enddo
6980         enddo
6981       enddo
6982 c      goto 1112
6983       endif
6984 c1111  continue
6985 C Contribution from graph II
6986       call transpose2(EE(1,1,itk),auxmat(1,1))
6987       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6988       vv(1)=pizda(1,1)+pizda(2,2)
6989       vv(2)=pizda(2,1)-pizda(1,2)
6990       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6991      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6992       if (calc_grad) then
6993 C Explicit gradient in virtual-dihedral angles.
6994       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6995      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6996       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6997       vv(1)=pizda(1,1)+pizda(2,2)
6998       vv(2)=pizda(2,1)-pizda(1,2)
6999       if (l.eq.j+1) then
7000         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7001      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7002      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7003       else
7004         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7005      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7006      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7007       endif
7008 C Cartesian gradient
7009       do iii=1,2
7010         do kkk=1,5
7011           do lll=1,3
7012             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7013      &        pizda(1,1))
7014             vv(1)=pizda(1,1)+pizda(2,2)
7015             vv(2)=pizda(2,1)-pizda(1,2)
7016             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7017      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7018      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7019           enddo
7020         enddo
7021       enddo
7022 cd      goto 1112
7023       endif
7024 cd1111  continue
7025       if (l.eq.j+1) then
7026 cd        goto 1110
7027 C Parallel orientation
7028 C Contribution from graph III
7029         call transpose2(EUg(1,1,l),auxmat(1,1))
7030         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7031         vv(1)=pizda(1,1)-pizda(2,2)
7032         vv(2)=pizda(1,2)+pizda(2,1)
7033         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7034      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7035         if (calc_grad) then
7036 C Explicit gradient in virtual-dihedral angles.
7037         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7038      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7039      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7040         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7041         vv(1)=pizda(1,1)-pizda(2,2)
7042         vv(2)=pizda(1,2)+pizda(2,1)
7043         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7044      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7045      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7046         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7047         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7048         vv(1)=pizda(1,1)-pizda(2,2)
7049         vv(2)=pizda(1,2)+pizda(2,1)
7050         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7051      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7052      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7053 C Cartesian gradient
7054         do iii=1,2
7055           do kkk=1,5
7056             do lll=1,3
7057               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7058      &          pizda(1,1))
7059               vv(1)=pizda(1,1)-pizda(2,2)
7060               vv(2)=pizda(1,2)+pizda(2,1)
7061               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7062      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7063      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7064             enddo
7065           enddo
7066         enddo
7067 cd        goto 1112
7068         endif
7069 C Contribution from graph IV
7070 cd1110    continue
7071         call transpose2(EE(1,1,itl),auxmat(1,1))
7072         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7073         vv(1)=pizda(1,1)+pizda(2,2)
7074         vv(2)=pizda(2,1)-pizda(1,2)
7075         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7076      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7077         if (calc_grad) then
7078 C Explicit gradient in virtual-dihedral angles.
7079         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7080      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7081         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7082         vv(1)=pizda(1,1)+pizda(2,2)
7083         vv(2)=pizda(2,1)-pizda(1,2)
7084         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7085      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7086      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7087 C Cartesian gradient
7088         do iii=1,2
7089           do kkk=1,5
7090             do lll=1,3
7091               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7092      &          pizda(1,1))
7093               vv(1)=pizda(1,1)+pizda(2,2)
7094               vv(2)=pizda(2,1)-pizda(1,2)
7095               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7096      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7097      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7098             enddo
7099           enddo
7100         enddo
7101         endif
7102       else
7103 C Antiparallel orientation
7104 C Contribution from graph III
7105 c        goto 1110
7106         call transpose2(EUg(1,1,j),auxmat(1,1))
7107         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7108         vv(1)=pizda(1,1)-pizda(2,2)
7109         vv(2)=pizda(1,2)+pizda(2,1)
7110         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7111      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7112         if (calc_grad) then
7113 C Explicit gradient in virtual-dihedral angles.
7114         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7115      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7116      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7117         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7118         vv(1)=pizda(1,1)-pizda(2,2)
7119         vv(2)=pizda(1,2)+pizda(2,1)
7120         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7121      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7122      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7123         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7124         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7125         vv(1)=pizda(1,1)-pizda(2,2)
7126         vv(2)=pizda(1,2)+pizda(2,1)
7127         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7128      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7129      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7130 C Cartesian gradient
7131         do iii=1,2
7132           do kkk=1,5
7133             do lll=1,3
7134               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7135      &          pizda(1,1))
7136               vv(1)=pizda(1,1)-pizda(2,2)
7137               vv(2)=pizda(1,2)+pizda(2,1)
7138               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7139      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7140      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7141             enddo
7142           enddo
7143         enddo
7144 cd        goto 1112
7145         endif
7146 C Contribution from graph IV
7147 1110    continue
7148         call transpose2(EE(1,1,itj),auxmat(1,1))
7149         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7150         vv(1)=pizda(1,1)+pizda(2,2)
7151         vv(2)=pizda(2,1)-pizda(1,2)
7152         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7153      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7154         if (calc_grad) then
7155 C Explicit gradient in virtual-dihedral angles.
7156         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7157      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7158         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7159         vv(1)=pizda(1,1)+pizda(2,2)
7160         vv(2)=pizda(2,1)-pizda(1,2)
7161         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7162      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7163      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7164 C Cartesian gradient
7165         do iii=1,2
7166           do kkk=1,5
7167             do lll=1,3
7168               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7169      &          pizda(1,1))
7170               vv(1)=pizda(1,1)+pizda(2,2)
7171               vv(2)=pizda(2,1)-pizda(1,2)
7172               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7173      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7174      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7175             enddo
7176           enddo
7177         enddo
7178       endif
7179       endif
7180 1112  continue
7181       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7182 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7183 cd        write (2,*) 'ijkl',i,j,k,l
7184 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7185 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7186 cd      endif
7187 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7188 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7189 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7190 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7191       if (calc_grad) then
7192       if (j.lt.nres-1) then
7193         j1=j+1
7194         j2=j-1
7195       else
7196         j1=j-1
7197         j2=j-2
7198       endif
7199       if (l.lt.nres-1) then
7200         l1=l+1
7201         l2=l-1
7202       else
7203         l1=l-1
7204         l2=l-2
7205       endif
7206 cd      eij=1.0d0
7207 cd      ekl=1.0d0
7208 cd      ekont=1.0d0
7209 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7210       do ll=1,3
7211         ggg1(ll)=eel5*g_contij(ll,1)
7212         ggg2(ll)=eel5*g_contij(ll,2)
7213 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7214         ghalf=0.5d0*ggg1(ll)
7215 cd        ghalf=0.0d0
7216         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7217         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7218         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7219         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7220 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7221         ghalf=0.5d0*ggg2(ll)
7222 cd        ghalf=0.0d0
7223         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7224         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7225         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7226         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7227       enddo
7228 cd      goto 1112
7229       do m=i+1,j-1
7230         do ll=1,3
7231 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7232           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7233         enddo
7234       enddo
7235       do m=k+1,l-1
7236         do ll=1,3
7237 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7238           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7239         enddo
7240       enddo
7241 c1112  continue
7242       do m=i+2,j2
7243         do ll=1,3
7244           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7245         enddo
7246       enddo
7247       do m=k+2,l2
7248         do ll=1,3
7249           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7250         enddo
7251       enddo
7252 cd      do iii=1,nres-3
7253 cd        write (2,*) iii,g_corr5_loc(iii)
7254 cd      enddo
7255       endif
7256       eello5=ekont*eel5
7257 cd      write (2,*) 'ekont',ekont
7258 cd      write (iout,*) 'eello5',ekont*eel5
7259       return
7260       end
7261 c--------------------------------------------------------------------------
7262       double precision function eello6(i,j,k,l,jj,kk)
7263       implicit real*8 (a-h,o-z)
7264       include 'DIMENSIONS'
7265       include 'DIMENSIONS.ZSCOPT'
7266       include 'COMMON.IOUNITS'
7267       include 'COMMON.CHAIN'
7268       include 'COMMON.DERIV'
7269       include 'COMMON.INTERACT'
7270       include 'COMMON.CONTACTS'
7271       include 'COMMON.TORSION'
7272       include 'COMMON.VAR'
7273       include 'COMMON.GEO'
7274       include 'COMMON.FFIELD'
7275       double precision ggg1(3),ggg2(3)
7276 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7277 cd        eello6=0.0d0
7278 cd        return
7279 cd      endif
7280 cd      write (iout,*)
7281 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7282 cd     &   ' and',k,l
7283       eello6_1=0.0d0
7284       eello6_2=0.0d0
7285       eello6_3=0.0d0
7286       eello6_4=0.0d0
7287       eello6_5=0.0d0
7288       eello6_6=0.0d0
7289 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7290 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7291       do iii=1,2
7292         do kkk=1,5
7293           do lll=1,3
7294             derx(lll,kkk,iii)=0.0d0
7295           enddo
7296         enddo
7297       enddo
7298 cd      eij=facont_hb(jj,i)
7299 cd      ekl=facont_hb(kk,k)
7300 cd      ekont=eij*ekl
7301 cd      eij=1.0d0
7302 cd      ekl=1.0d0
7303 cd      ekont=1.0d0
7304       if (l.eq.j+1) then
7305         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7306         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7307         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7308         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7309         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7310         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7311       else
7312         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7313         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7314         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7315         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7316         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7317           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7318         else
7319           eello6_5=0.0d0
7320         endif
7321         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7322       endif
7323 C If turn contributions are considered, they will be handled separately.
7324       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7325 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7326 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7327 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7328 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7329 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7330 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7331 cd      goto 1112
7332       if (calc_grad) then
7333       if (j.lt.nres-1) then
7334         j1=j+1
7335         j2=j-1
7336       else
7337         j1=j-1
7338         j2=j-2
7339       endif
7340       if (l.lt.nres-1) then
7341         l1=l+1
7342         l2=l-1
7343       else
7344         l1=l-1
7345         l2=l-2
7346       endif
7347       do ll=1,3
7348         ggg1(ll)=eel6*g_contij(ll,1)
7349         ggg2(ll)=eel6*g_contij(ll,2)
7350 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7351         ghalf=0.5d0*ggg1(ll)
7352 cd        ghalf=0.0d0
7353         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7354         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7355         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7356         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7357         ghalf=0.5d0*ggg2(ll)
7358 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7359 cd        ghalf=0.0d0
7360         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7361         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7362         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7363         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7364       enddo
7365 cd      goto 1112
7366       do m=i+1,j-1
7367         do ll=1,3
7368 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7369           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7370         enddo
7371       enddo
7372       do m=k+1,l-1
7373         do ll=1,3
7374 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7375           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7376         enddo
7377       enddo
7378 1112  continue
7379       do m=i+2,j2
7380         do ll=1,3
7381           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7382         enddo
7383       enddo
7384       do m=k+2,l2
7385         do ll=1,3
7386           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7387         enddo
7388       enddo
7389 cd      do iii=1,nres-3
7390 cd        write (2,*) iii,g_corr6_loc(iii)
7391 cd      enddo
7392       endif
7393       eello6=ekont*eel6
7394 cd      write (2,*) 'ekont',ekont
7395 cd      write (iout,*) 'eello6',ekont*eel6
7396       return
7397       end
7398 c--------------------------------------------------------------------------
7399       double precision function eello6_graph1(i,j,k,l,imat,swap)
7400       implicit real*8 (a-h,o-z)
7401       include 'DIMENSIONS'
7402       include 'DIMENSIONS.ZSCOPT'
7403       include 'COMMON.IOUNITS'
7404       include 'COMMON.CHAIN'
7405       include 'COMMON.DERIV'
7406       include 'COMMON.INTERACT'
7407       include 'COMMON.CONTACTS'
7408       include 'COMMON.TORSION'
7409       include 'COMMON.VAR'
7410       include 'COMMON.GEO'
7411       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7412       logical swap
7413       logical lprn
7414       common /kutas/ lprn
7415 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7416 C                                                                              C
7417 C      Parallel       Antiparallel                                             C
7418 C                                                                              C
7419 C          o             o                                                     C
7420 C         /l\           /j\                                                    C
7421 C        /   \         /   \                                                   C
7422 C       /| o |         | o |\                                                  C
7423 C     \ j|/k\|  /   \  |/k\|l /                                                C
7424 C      \ /   \ /     \ /   \ /                                                 C
7425 C       o     o       o     o                                                  C
7426 C       i             i                                                        C
7427 C                                                                              C
7428 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7429       itk=itortyp(itype(k))
7430       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7431       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7432       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7433       call transpose2(EUgC(1,1,k),auxmat(1,1))
7434       call matmat2(AEA(1,1,imat),auxmat(1,1),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)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7439       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7440       s5=scalar2(vv(1),Dtobr2(1,i))
7441 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7442       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7443       if (.not. calc_grad) return
7444       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7445      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7446      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7447      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7448      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7449      & +scalar2(vv(1),Dtobr2der(1,i)))
7450       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7451       vv1(1)=pizda1(1,1)-pizda1(2,2)
7452       vv1(2)=pizda1(1,2)+pizda1(2,1)
7453       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7454       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7455       if (l.eq.j+1) then
7456         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7457      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7458      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7459      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7460      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7461       else
7462         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7463      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7464      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7465      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7466      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7467       endif
7468       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7469       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7470       vv1(1)=pizda1(1,1)-pizda1(2,2)
7471       vv1(2)=pizda1(1,2)+pizda1(2,1)
7472       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7473      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7474      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7475      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7476       do iii=1,2
7477         if (swap) then
7478           ind=3-iii
7479         else
7480           ind=iii
7481         endif
7482         do kkk=1,5
7483           do lll=1,3
7484             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7485             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7486             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7487             call transpose2(EUgC(1,1,k),auxmat(1,1))
7488             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7489      &        pizda1(1,1))
7490             vv1(1)=pizda1(1,1)-pizda1(2,2)
7491             vv1(2)=pizda1(1,2)+pizda1(2,1)
7492             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7493             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7494      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7495             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7496      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7497             s5=scalar2(vv(1),Dtobr2(1,i))
7498             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7499           enddo
7500         enddo
7501       enddo
7502       return
7503       end
7504 c----------------------------------------------------------------------------
7505       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7506       implicit real*8 (a-h,o-z)
7507       include 'DIMENSIONS'
7508       include 'DIMENSIONS.ZSCOPT'
7509       include 'COMMON.IOUNITS'
7510       include 'COMMON.CHAIN'
7511       include 'COMMON.DERIV'
7512       include 'COMMON.INTERACT'
7513       include 'COMMON.CONTACTS'
7514       include 'COMMON.TORSION'
7515       include 'COMMON.VAR'
7516       include 'COMMON.GEO'
7517       logical swap
7518       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7519      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7520       logical lprn
7521       common /kutas/ lprn
7522 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7523 C                                                                              C
7524 C      Parallel       Antiparallel                                             C
7525 C                                                                              C
7526 C          o             o                                                     C
7527 C     \   /l\           /j\   /                                                C
7528 C      \ /   \         /   \ /                                                 C
7529 C       o| o |         | o |o                                                  C
7530 C     \ j|/k\|      \  |/k\|l                                                  C
7531 C      \ /   \       \ /   \                                                   C
7532 C       o             o                                                        C
7533 C       i             i                                                        C
7534 C                                                                              C
7535 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7536 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7537 C AL 7/4/01 s1 would occur in the sixth-order moment,
7538 C           but not in a cluster cumulant
7539 #ifdef MOMENT
7540       s1=dip(1,jj,i)*dip(1,kk,k)
7541 #endif
7542       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7543       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7544       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7545       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7546       call transpose2(EUg(1,1,k),auxmat(1,1))
7547       call matmat2(ADtEA1(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 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7552 #ifdef MOMENT
7553       eello6_graph2=-(s1+s2+s3+s4)
7554 #else
7555       eello6_graph2=-(s2+s3+s4)
7556 #endif
7557 c      eello6_graph2=-s3
7558       if (.not. calc_grad) return
7559 C Derivatives in gamma(i-1)
7560       if (i.gt.1) then
7561 #ifdef MOMENT
7562         s1=dipderg(1,jj,i)*dip(1,kk,k)
7563 #endif
7564         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7565         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7566         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7567         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7568 #ifdef MOMENT
7569         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7570 #else
7571         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7572 #endif
7573 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7574       endif
7575 C Derivatives in gamma(k-1)
7576 #ifdef MOMENT
7577       s1=dip(1,jj,i)*dipderg(1,kk,k)
7578 #endif
7579       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7580       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7581       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7582       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7583       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7584       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7585       vv(1)=pizda(1,1)-pizda(2,2)
7586       vv(2)=pizda(1,2)+pizda(2,1)
7587       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7588 #ifdef MOMENT
7589       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7590 #else
7591       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7592 #endif
7593 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7594 C Derivatives in gamma(j-1) or gamma(l-1)
7595       if (j.gt.1) then
7596 #ifdef MOMENT
7597         s1=dipderg(3,jj,i)*dip(1,kk,k)
7598 #endif
7599         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7600         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7601         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7602         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7603         vv(1)=pizda(1,1)-pizda(2,2)
7604         vv(2)=pizda(1,2)+pizda(2,1)
7605         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7606 #ifdef MOMENT
7607         if (swap) then
7608           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7609         else
7610           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7611         endif
7612 #endif
7613         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7614 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7615       endif
7616 C Derivatives in gamma(l-1) or gamma(j-1)
7617       if (l.gt.1) then
7618 #ifdef MOMENT
7619         s1=dip(1,jj,i)*dipderg(3,kk,k)
7620 #endif
7621         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7622         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7623         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7624         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7625         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7626         vv(1)=pizda(1,1)-pizda(2,2)
7627         vv(2)=pizda(1,2)+pizda(2,1)
7628         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7629 #ifdef MOMENT
7630         if (swap) then
7631           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7632         else
7633           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7634         endif
7635 #endif
7636         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7637 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7638       endif
7639 C Cartesian derivatives.
7640       if (lprn) then
7641         write (2,*) 'In eello6_graph2'
7642         do iii=1,2
7643           write (2,*) 'iii=',iii
7644           do kkk=1,5
7645             write (2,*) 'kkk=',kkk
7646             do jjj=1,2
7647               write (2,'(3(2f10.5),5x)')
7648      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7649             enddo
7650           enddo
7651         enddo
7652       endif
7653       do iii=1,2
7654         do kkk=1,5
7655           do lll=1,3
7656 #ifdef MOMENT
7657             if (iii.eq.1) then
7658               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7659             else
7660               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7661             endif
7662 #endif
7663             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7664      &        auxvec(1))
7665             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7666             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7667      &        auxvec(1))
7668             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7669             call transpose2(EUg(1,1,k),auxmat(1,1))
7670             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7671      &        pizda(1,1))
7672             vv(1)=pizda(1,1)-pizda(2,2)
7673             vv(2)=pizda(1,2)+pizda(2,1)
7674             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7675 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7676 #ifdef MOMENT
7677             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7678 #else
7679             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7680 #endif
7681             if (swap) then
7682               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7683             else
7684               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7685             endif
7686           enddo
7687         enddo
7688       enddo
7689       return
7690       end
7691 c----------------------------------------------------------------------------
7692       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7693       implicit real*8 (a-h,o-z)
7694       include 'DIMENSIONS'
7695       include 'DIMENSIONS.ZSCOPT'
7696       include 'COMMON.IOUNITS'
7697       include 'COMMON.CHAIN'
7698       include 'COMMON.DERIV'
7699       include 'COMMON.INTERACT'
7700       include 'COMMON.CONTACTS'
7701       include 'COMMON.TORSION'
7702       include 'COMMON.VAR'
7703       include 'COMMON.GEO'
7704       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7705       logical swap
7706 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7707 C                                                                              C
7708 C      Parallel       Antiparallel                                             C
7709 C                                                                              C
7710 C          o             o                                                     C
7711 C         /l\   /   \   /j\                                                    C
7712 C        /   \ /     \ /   \                                                   C
7713 C       /| o |o       o| o |\                                                  C
7714 C       j|/k\|  /      |/k\|l /                                                C
7715 C        /   \ /       /   \ /                                                 C
7716 C       /     o       /     o                                                  C
7717 C       i             i                                                        C
7718 C                                                                              C
7719 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7720 C
7721 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7722 C           energy moment and not to the cluster cumulant.
7723       iti=itortyp(itype(i))
7724       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7725         itj1=itortyp(itype(j+1))
7726       else
7727         itj1=ntortyp+1
7728       endif
7729       itk=itortyp(itype(k))
7730       itk1=itortyp(itype(k+1))
7731       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7732         itl1=itortyp(itype(l+1))
7733       else
7734         itl1=ntortyp+1
7735       endif
7736 #ifdef MOMENT
7737       s1=dip(4,jj,i)*dip(4,kk,k)
7738 #endif
7739       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7740       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7741       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7742       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7743       call transpose2(EE(1,1,itk),auxmat(1,1))
7744       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7745       vv(1)=pizda(1,1)+pizda(2,2)
7746       vv(2)=pizda(2,1)-pizda(1,2)
7747       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7748 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7749 #ifdef MOMENT
7750       eello6_graph3=-(s1+s2+s3+s4)
7751 #else
7752       eello6_graph3=-(s2+s3+s4)
7753 #endif
7754 c      eello6_graph3=-s4
7755       if (.not. calc_grad) return
7756 C Derivatives in gamma(k-1)
7757       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7758       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7759       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7760       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7761 C Derivatives in gamma(l-1)
7762       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7763       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7764       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7765       vv(1)=pizda(1,1)+pizda(2,2)
7766       vv(2)=pizda(2,1)-pizda(1,2)
7767       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7768       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7769 C Cartesian derivatives.
7770       do iii=1,2
7771         do kkk=1,5
7772           do lll=1,3
7773 #ifdef MOMENT
7774             if (iii.eq.1) then
7775               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7776             else
7777               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7778             endif
7779 #endif
7780             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7781      &        auxvec(1))
7782             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7783             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7784      &        auxvec(1))
7785             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7786             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7787      &        pizda(1,1))
7788             vv(1)=pizda(1,1)+pizda(2,2)
7789             vv(2)=pizda(2,1)-pizda(1,2)
7790             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7791 #ifdef MOMENT
7792             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7793 #else
7794             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7795 #endif
7796             if (swap) then
7797               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7798             else
7799               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7800             endif
7801 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7802           enddo
7803         enddo
7804       enddo
7805       return
7806       end
7807 c----------------------------------------------------------------------------
7808       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7809       implicit real*8 (a-h,o-z)
7810       include 'DIMENSIONS'
7811       include 'DIMENSIONS.ZSCOPT'
7812       include 'COMMON.IOUNITS'
7813       include 'COMMON.CHAIN'
7814       include 'COMMON.DERIV'
7815       include 'COMMON.INTERACT'
7816       include 'COMMON.CONTACTS'
7817       include 'COMMON.TORSION'
7818       include 'COMMON.VAR'
7819       include 'COMMON.GEO'
7820       include 'COMMON.FFIELD'
7821       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7822      & auxvec1(2),auxmat1(2,2)
7823       logical swap
7824 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7825 C                                                                              C
7826 C      Parallel       Antiparallel                                             C
7827 C                                                                              C
7828 C          o             o                                                     C
7829 C         /l\   /   \   /j\                                                    C
7830 C        /   \ /     \ /   \                                                   C
7831 C       /| o |o       o| o |\                                                  C
7832 C     \ j|/k\|      \  |/k\|l                                                  C
7833 C      \ /   \       \ /   \                                                   C
7834 C       o     \       o     \                                                  C
7835 C       i             i                                                        C
7836 C                                                                              C
7837 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7838 C
7839 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7840 C           energy moment and not to the cluster cumulant.
7841 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7842       iti=itortyp(itype(i))
7843       itj=itortyp(itype(j))
7844       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7845         itj1=itortyp(itype(j+1))
7846       else
7847         itj1=ntortyp+1
7848       endif
7849       itk=itortyp(itype(k))
7850       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7851         itk1=itortyp(itype(k+1))
7852       else
7853         itk1=ntortyp+1
7854       endif
7855       itl=itortyp(itype(l))
7856       if (l.lt.nres-1) then
7857         itl1=itortyp(itype(l+1))
7858       else
7859         itl1=ntortyp+1
7860       endif
7861 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7862 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7863 cd     & ' itl',itl,' itl1',itl1
7864 #ifdef MOMENT
7865       if (imat.eq.1) then
7866         s1=dip(3,jj,i)*dip(3,kk,k)
7867       else
7868         s1=dip(2,jj,j)*dip(2,kk,l)
7869       endif
7870 #endif
7871       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7872       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7873       if (j.eq.l+1) then
7874         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7875         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7876       else
7877         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7878         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7879       endif
7880       call transpose2(EUg(1,1,k),auxmat(1,1))
7881       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7882       vv(1)=pizda(1,1)-pizda(2,2)
7883       vv(2)=pizda(2,1)+pizda(1,2)
7884       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7885 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7886 #ifdef MOMENT
7887       eello6_graph4=-(s1+s2+s3+s4)
7888 #else
7889       eello6_graph4=-(s2+s3+s4)
7890 #endif
7891       if (.not. calc_grad) return
7892 C Derivatives in gamma(i-1)
7893       if (i.gt.1) then
7894 #ifdef MOMENT
7895         if (imat.eq.1) then
7896           s1=dipderg(2,jj,i)*dip(3,kk,k)
7897         else
7898           s1=dipderg(4,jj,j)*dip(2,kk,l)
7899         endif
7900 #endif
7901         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7902         if (j.eq.l+1) then
7903           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7904           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7905         else
7906           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7907           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7908         endif
7909         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7910         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7911 cd          write (2,*) 'turn6 derivatives'
7912 #ifdef MOMENT
7913           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7914 #else
7915           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7916 #endif
7917         else
7918 #ifdef MOMENT
7919           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7920 #else
7921           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7922 #endif
7923         endif
7924       endif
7925 C Derivatives in gamma(k-1)
7926 #ifdef MOMENT
7927       if (imat.eq.1) then
7928         s1=dip(3,jj,i)*dipderg(2,kk,k)
7929       else
7930         s1=dip(2,jj,j)*dipderg(4,kk,l)
7931       endif
7932 #endif
7933       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7934       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7935       if (j.eq.l+1) then
7936         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7937         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7938       else
7939         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7940         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7941       endif
7942       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7943       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7944       vv(1)=pizda(1,1)-pizda(2,2)
7945       vv(2)=pizda(2,1)+pizda(1,2)
7946       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7947       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7948 #ifdef MOMENT
7949         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7950 #else
7951         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7952 #endif
7953       else
7954 #ifdef MOMENT
7955         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7956 #else
7957         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7958 #endif
7959       endif
7960 C Derivatives in gamma(j-1) or gamma(l-1)
7961       if (l.eq.j+1 .and. l.gt.1) then
7962         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7963         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7964         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7965         vv(1)=pizda(1,1)-pizda(2,2)
7966         vv(2)=pizda(2,1)+pizda(1,2)
7967         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7968         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7969       else if (j.gt.1) then
7970         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7971         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7972         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7973         vv(1)=pizda(1,1)-pizda(2,2)
7974         vv(2)=pizda(2,1)+pizda(1,2)
7975         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7976         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7977           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7978         else
7979           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7980         endif
7981       endif
7982 C Cartesian derivatives.
7983       do iii=1,2
7984         do kkk=1,5
7985           do lll=1,3
7986 #ifdef MOMENT
7987             if (iii.eq.1) then
7988               if (imat.eq.1) then
7989                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7990               else
7991                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7992               endif
7993             else
7994               if (imat.eq.1) then
7995                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7996               else
7997                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7998               endif
7999             endif
8000 #endif
8001             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8002      &        auxvec(1))
8003             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8004             if (j.eq.l+1) then
8005               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8006      &          b1(1,itj1),auxvec(1))
8007               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8008             else
8009               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8010      &          b1(1,itl1),auxvec(1))
8011               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8012             endif
8013             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8014      &        pizda(1,1))
8015             vv(1)=pizda(1,1)-pizda(2,2)
8016             vv(2)=pizda(2,1)+pizda(1,2)
8017             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8018             if (swap) then
8019               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8020 #ifdef MOMENT
8021                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8022      &             -(s1+s2+s4)
8023 #else
8024                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8025      &             -(s2+s4)
8026 #endif
8027                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8028               else
8029 #ifdef MOMENT
8030                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8031 #else
8032                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8033 #endif
8034                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8035               endif
8036             else
8037 #ifdef MOMENT
8038               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8039 #else
8040               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8041 #endif
8042               if (l.eq.j+1) then
8043                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8044               else
8045                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8046               endif
8047             endif
8048           enddo
8049         enddo
8050       enddo
8051       return
8052       end
8053 c----------------------------------------------------------------------------
8054       double precision function eello_turn6(i,jj,kk)
8055       implicit real*8 (a-h,o-z)
8056       include 'DIMENSIONS'
8057       include 'DIMENSIONS.ZSCOPT'
8058       include 'COMMON.IOUNITS'
8059       include 'COMMON.CHAIN'
8060       include 'COMMON.DERIV'
8061       include 'COMMON.INTERACT'
8062       include 'COMMON.CONTACTS'
8063       include 'COMMON.TORSION'
8064       include 'COMMON.VAR'
8065       include 'COMMON.GEO'
8066       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8067      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8068      &  ggg1(3),ggg2(3)
8069       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8070      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8071 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8072 C           the respective energy moment and not to the cluster cumulant.
8073       eello_turn6=0.0d0
8074       j=i+4
8075       k=i+1
8076       l=i+3
8077       iti=itortyp(itype(i))
8078       itk=itortyp(itype(k))
8079       itk1=itortyp(itype(k+1))
8080       itl=itortyp(itype(l))
8081       itj=itortyp(itype(j))
8082 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8083 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8084 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8085 cd        eello6=0.0d0
8086 cd        return
8087 cd      endif
8088 cd      write (iout,*)
8089 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8090 cd     &   ' and',k,l
8091 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8092       do iii=1,2
8093         do kkk=1,5
8094           do lll=1,3
8095             derx_turn(lll,kkk,iii)=0.0d0
8096           enddo
8097         enddo
8098       enddo
8099 cd      eij=1.0d0
8100 cd      ekl=1.0d0
8101 cd      ekont=1.0d0
8102       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8103 cd      eello6_5=0.0d0
8104 cd      write (2,*) 'eello6_5',eello6_5
8105 #ifdef MOMENT
8106       call transpose2(AEA(1,1,1),auxmat(1,1))
8107       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8108       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8109       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8110 #else
8111       s1 = 0.0d0
8112 #endif
8113       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8114       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8115       s2 = scalar2(b1(1,itk),vtemp1(1))
8116 #ifdef MOMENT
8117       call transpose2(AEA(1,1,2),atemp(1,1))
8118       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8119       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8120       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8121 #else
8122       s8=0.0d0
8123 #endif
8124       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8125       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8126       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8127 #ifdef MOMENT
8128       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8129       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8130       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8131       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8132       ss13 = scalar2(b1(1,itk),vtemp4(1))
8133       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8134 #else
8135       s13=0.0d0
8136 #endif
8137 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8138 c      s1=0.0d0
8139 c      s2=0.0d0
8140 c      s8=0.0d0
8141 c      s12=0.0d0
8142 c      s13=0.0d0
8143       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8144       if (calc_grad) then
8145 C Derivatives in gamma(i+2)
8146 #ifdef MOMENT
8147       call transpose2(AEA(1,1,1),auxmatd(1,1))
8148       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8149       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8150       call transpose2(AEAderg(1,1,2),atempd(1,1))
8151       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8152       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8153 #else
8154       s8d=0.0d0
8155 #endif
8156       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8157       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8158       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8159 c      s1d=0.0d0
8160 c      s2d=0.0d0
8161 c      s8d=0.0d0
8162 c      s12d=0.0d0
8163 c      s13d=0.0d0
8164       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8165 C Derivatives in gamma(i+3)
8166 #ifdef MOMENT
8167       call transpose2(AEA(1,1,1),auxmatd(1,1))
8168       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8169       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8170       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8171 #else
8172       s1d=0.0d0
8173 #endif
8174       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8175       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8176       s2d = scalar2(b1(1,itk),vtemp1d(1))
8177 #ifdef MOMENT
8178       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8179       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8180 #endif
8181       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8182 #ifdef MOMENT
8183       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8184       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8185       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8186 #else
8187       s13d=0.0d0
8188 #endif
8189 c      s1d=0.0d0
8190 c      s2d=0.0d0
8191 c      s8d=0.0d0
8192 c      s12d=0.0d0
8193 c      s13d=0.0d0
8194 #ifdef MOMENT
8195       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8196      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8197 #else
8198       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8199      &               -0.5d0*ekont*(s2d+s12d)
8200 #endif
8201 C Derivatives in gamma(i+4)
8202       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8203       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8204       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8205 #ifdef MOMENT
8206       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8207       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8208       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8209 #else
8210       s13d = 0.0d0
8211 #endif
8212 c      s1d=0.0d0
8213 c      s2d=0.0d0
8214 c      s8d=0.0d0
8215 C      s12d=0.0d0
8216 c      s13d=0.0d0
8217 #ifdef MOMENT
8218       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8219 #else
8220       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8221 #endif
8222 C Derivatives in gamma(i+5)
8223 #ifdef MOMENT
8224       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8225       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8226       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8227 #else
8228       s1d = 0.0d0
8229 #endif
8230       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8231       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8232       s2d = scalar2(b1(1,itk),vtemp1d(1))
8233 #ifdef MOMENT
8234       call transpose2(AEA(1,1,2),atempd(1,1))
8235       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8236       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8237 #else
8238       s8d = 0.0d0
8239 #endif
8240       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8241       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8242 #ifdef MOMENT
8243       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8244       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8245       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8246 #else
8247       s13d = 0.0d0
8248 #endif
8249 c      s1d=0.0d0
8250 c      s2d=0.0d0
8251 c      s8d=0.0d0
8252 c      s12d=0.0d0
8253 c      s13d=0.0d0
8254 #ifdef MOMENT
8255       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8256      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8257 #else
8258       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8259      &               -0.5d0*ekont*(s2d+s12d)
8260 #endif
8261 C Cartesian derivatives
8262       do iii=1,2
8263         do kkk=1,5
8264           do lll=1,3
8265 #ifdef MOMENT
8266             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8267             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8268             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8269 #else
8270             s1d = 0.0d0
8271 #endif
8272             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8273             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8274      &          vtemp1d(1))
8275             s2d = scalar2(b1(1,itk),vtemp1d(1))
8276 #ifdef MOMENT
8277             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8278             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8279             s8d = -(atempd(1,1)+atempd(2,2))*
8280      &           scalar2(cc(1,1,itl),vtemp2(1))
8281 #else
8282             s8d = 0.0d0
8283 #endif
8284             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8285      &           auxmatd(1,1))
8286             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8287             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8288 c      s1d=0.0d0
8289 c      s2d=0.0d0
8290 c      s8d=0.0d0
8291 c      s12d=0.0d0
8292 c      s13d=0.0d0
8293 #ifdef MOMENT
8294             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8295      &        - 0.5d0*(s1d+s2d)
8296 #else
8297             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8298      &        - 0.5d0*s2d
8299 #endif
8300 #ifdef MOMENT
8301             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8302      &        - 0.5d0*(s8d+s12d)
8303 #else
8304             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8305      &        - 0.5d0*s12d
8306 #endif
8307           enddo
8308         enddo
8309       enddo
8310 #ifdef MOMENT
8311       do kkk=1,5
8312         do lll=1,3
8313           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8314      &      achuj_tempd(1,1))
8315           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8316           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8317           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8318           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8319           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8320      &      vtemp4d(1))
8321           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8322           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8323           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8324         enddo
8325       enddo
8326 #endif
8327 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8328 cd     &  16*eel_turn6_num
8329 cd      goto 1112
8330       if (j.lt.nres-1) then
8331         j1=j+1
8332         j2=j-1
8333       else
8334         j1=j-1
8335         j2=j-2
8336       endif
8337       if (l.lt.nres-1) then
8338         l1=l+1
8339         l2=l-1
8340       else
8341         l1=l-1
8342         l2=l-2
8343       endif
8344       do ll=1,3
8345         ggg1(ll)=eel_turn6*g_contij(ll,1)
8346         ggg2(ll)=eel_turn6*g_contij(ll,2)
8347         ghalf=0.5d0*ggg1(ll)
8348 cd        ghalf=0.0d0
8349         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8350      &    +ekont*derx_turn(ll,2,1)
8351         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8352         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8353      &    +ekont*derx_turn(ll,4,1)
8354         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8355         ghalf=0.5d0*ggg2(ll)
8356 cd        ghalf=0.0d0
8357         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8358      &    +ekont*derx_turn(ll,2,2)
8359         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8360         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8361      &    +ekont*derx_turn(ll,4,2)
8362         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8363       enddo
8364 cd      goto 1112
8365       do m=i+1,j-1
8366         do ll=1,3
8367           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8368         enddo
8369       enddo
8370       do m=k+1,l-1
8371         do ll=1,3
8372           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8373         enddo
8374       enddo
8375 1112  continue
8376       do m=i+2,j2
8377         do ll=1,3
8378           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8379         enddo
8380       enddo
8381       do m=k+2,l2
8382         do ll=1,3
8383           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8384         enddo
8385       enddo
8386 cd      do iii=1,nres-3
8387 cd        write (2,*) iii,g_corr6_loc(iii)
8388 cd      enddo
8389       endif
8390       eello_turn6=ekont*eel_turn6
8391 cd      write (2,*) 'ekont',ekont
8392 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8393       return
8394       end
8395 crc-------------------------------------------------
8396 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8397       subroutine Eliptransfer(eliptran)
8398       implicit real*8 (a-h,o-z)
8399       include 'DIMENSIONS'
8400       include 'COMMON.GEO'
8401       include 'COMMON.VAR'
8402       include 'COMMON.LOCAL'
8403       include 'COMMON.CHAIN'
8404       include 'COMMON.DERIV'
8405       include 'COMMON.INTERACT'
8406       include 'COMMON.IOUNITS'
8407       include 'COMMON.CALC'
8408       include 'COMMON.CONTROL'
8409       include 'COMMON.SPLITELE'
8410       include 'COMMON.SBRIDGE'
8411 C this is done by Adasko
8412 C      print *,"wchodze"
8413 C structure of box:
8414 C      water
8415 C--bordliptop-- buffore starts
8416 C--bufliptop--- here true lipid starts
8417 C      lipid
8418 C--buflipbot--- lipid ends buffore starts
8419 C--bordlipbot--buffore ends
8420       eliptran=0.0
8421       do i=1,nres
8422 C       do i=1,1
8423         if (itype(i).eq.ntyp1) cycle
8424
8425         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8426         if (positi.le.0) positi=positi+boxzsize
8427 C        print *,i
8428 C first for peptide groups
8429 c for each residue check if it is in lipid or lipid water border area
8430        if ((positi.gt.bordlipbot)
8431      &.and.(positi.lt.bordliptop)) then
8432 C the energy transfer exist
8433         if (positi.lt.buflipbot) then
8434 C what fraction I am in
8435          fracinbuf=1.0d0-
8436      &        ((positi-bordlipbot)/lipbufthick)
8437 C lipbufthick is thickenes of lipid buffore
8438          sslip=sscalelip(fracinbuf)
8439          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8440          eliptran=eliptran+sslip*pepliptran
8441          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8442          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8443 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8444         elseif (positi.gt.bufliptop) then
8445          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8446          sslip=sscalelip(fracinbuf)
8447          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8448          eliptran=eliptran+sslip*pepliptran
8449          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8450          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8451 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8452 C          print *, "doing sscalefor top part"
8453 C         print *,i,sslip,fracinbuf,ssgradlip
8454         else
8455          eliptran=eliptran+pepliptran
8456 C         print *,"I am in true lipid"
8457         endif
8458 C       else
8459 C       eliptran=elpitran+0.0 ! I am in water
8460        endif
8461        enddo
8462 C       print *, "nic nie bylo w lipidzie?"
8463 C now multiply all by the peptide group transfer factor
8464 C       eliptran=eliptran*pepliptran
8465 C now the same for side chains
8466 CV       do i=1,1
8467        do i=1,nres
8468         if (itype(i).eq.ntyp1) cycle
8469         positi=(mod(c(3,i+nres),boxzsize))
8470         if (positi.le.0) positi=positi+boxzsize
8471 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8472 c for each residue check if it is in lipid or lipid water border area
8473 C       respos=mod(c(3,i+nres),boxzsize)
8474 C       print *,positi,bordlipbot,buflipbot
8475        if ((positi.gt.bordlipbot)
8476      & .and.(positi.lt.bordliptop)) then
8477 C the energy transfer exist
8478         if (positi.lt.buflipbot) then
8479          fracinbuf=1.0d0-
8480      &     ((positi-bordlipbot)/lipbufthick)
8481 C lipbufthick is thickenes of lipid buffore
8482          sslip=sscalelip(fracinbuf)
8483          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8484          eliptran=eliptran+sslip*liptranene(itype(i))
8485          gliptranx(3,i)=gliptranx(3,i)
8486      &+ssgradlip*liptranene(itype(i))
8487          gliptranc(3,i-1)= gliptranc(3,i-1)
8488      &+ssgradlip*liptranene(itype(i))
8489 C         print *,"doing sccale for lower part"
8490         elseif (positi.gt.bufliptop) then
8491          fracinbuf=1.0d0-
8492      &((bordliptop-positi)/lipbufthick)
8493          sslip=sscalelip(fracinbuf)
8494          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8495          eliptran=eliptran+sslip*liptranene(itype(i))
8496          gliptranx(3,i)=gliptranx(3,i)
8497      &+ssgradlip*liptranene(itype(i))
8498          gliptranc(3,i-1)= gliptranc(3,i-1)
8499      &+ssgradlip*liptranene(itype(i))
8500 C          print *, "doing sscalefor top part",sslip,fracinbuf
8501         else
8502          eliptran=eliptran+liptranene(itype(i))
8503 C         print *,"I am in true lipid"
8504         endif
8505         endif ! if in lipid or buffor
8506 C       else
8507 C       eliptran=elpitran+0.0 ! I am in water
8508        enddo
8509        return
8510        end
8511
8512
8513 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8514
8515       SUBROUTINE MATVEC2(A1,V1,V2)
8516       implicit real*8 (a-h,o-z)
8517       include 'DIMENSIONS'
8518       DIMENSION A1(2,2),V1(2),V2(2)
8519 c      DO 1 I=1,2
8520 c        VI=0.0
8521 c        DO 3 K=1,2
8522 c    3     VI=VI+A1(I,K)*V1(K)
8523 c        Vaux(I)=VI
8524 c    1 CONTINUE
8525
8526       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8527       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8528
8529       v2(1)=vaux1
8530       v2(2)=vaux2
8531       END
8532 C---------------------------------------
8533       SUBROUTINE MATMAT2(A1,A2,A3)
8534       implicit real*8 (a-h,o-z)
8535       include 'DIMENSIONS'
8536       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8537 c      DIMENSION AI3(2,2)
8538 c        DO  J=1,2
8539 c          A3IJ=0.0
8540 c          DO K=1,2
8541 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8542 c          enddo
8543 c          A3(I,J)=A3IJ
8544 c       enddo
8545 c      enddo
8546
8547       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8548       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8549       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8550       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8551
8552       A3(1,1)=AI3_11
8553       A3(2,1)=AI3_21
8554       A3(1,2)=AI3_12
8555       A3(2,2)=AI3_22
8556       END
8557
8558 c-------------------------------------------------------------------------
8559       double precision function scalar2(u,v)
8560       implicit none
8561       double precision u(2),v(2)
8562       double precision sc
8563       integer i
8564       scalar2=u(1)*v(1)+u(2)*v(2)
8565       return
8566       end
8567
8568 C-----------------------------------------------------------------------------
8569
8570       subroutine transpose2(a,at)
8571       implicit none
8572       double precision a(2,2),at(2,2)
8573       at(1,1)=a(1,1)
8574       at(1,2)=a(2,1)
8575       at(2,1)=a(1,2)
8576       at(2,2)=a(2,2)
8577       return
8578       end
8579 c--------------------------------------------------------------------------
8580       subroutine transpose(n,a,at)
8581       implicit none
8582       integer n,i,j
8583       double precision a(n,n),at(n,n)
8584       do i=1,n
8585         do j=1,n
8586           at(j,i)=a(i,j)
8587         enddo
8588       enddo
8589       return
8590       end
8591 C---------------------------------------------------------------------------
8592       subroutine prodmat3(a1,a2,kk,transp,prod)
8593       implicit none
8594       integer i,j
8595       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8596       logical transp
8597 crc      double precision auxmat(2,2),prod_(2,2)
8598
8599       if (transp) then
8600 crc        call transpose2(kk(1,1),auxmat(1,1))
8601 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8602 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8603
8604            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8605      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8606            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8607      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8608            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8609      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8610            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8611      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8612
8613       else
8614 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8615 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8616
8617            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8618      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8619            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8620      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8621            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8622      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8623            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8624      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8625
8626       endif
8627 c      call transpose2(a2(1,1),a2t(1,1))
8628
8629 crc      print *,transp
8630 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8631 crc      print *,((prod(i,j),i=1,2),j=1,2)
8632
8633       return
8634       end
8635 C-----------------------------------------------------------------------------
8636       double precision function scalar(u,v)
8637       implicit none
8638       double precision u(3),v(3)
8639       double precision sc
8640       integer i
8641       sc=0.0d0
8642       do i=1,3
8643         sc=sc+u(i)*v(i)
8644       enddo
8645       scalar=sc
8646       return
8647       end
8648 C-----------------------------------------------------------------------
8649       double precision function sscale(r)
8650       double precision r,gamm
8651       include "COMMON.SPLITELE"
8652       if(r.lt.r_cut-rlamb) then
8653         sscale=1.0d0
8654       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8655         gamm=(r-(r_cut-rlamb))/rlamb
8656         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8657       else
8658         sscale=0d0
8659       endif
8660       return
8661       end
8662 C-----------------------------------------------------------------------
8663 C-----------------------------------------------------------------------
8664       double precision function sscagrad(r)
8665       double precision r,gamm
8666       include "COMMON.SPLITELE"
8667       if(r.lt.r_cut-rlamb) then
8668         sscagrad=0.0d0
8669       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8670         gamm=(r-(r_cut-rlamb))/rlamb
8671         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8672       else
8673         sscagrad=0.0d0
8674       endif
8675       return
8676       end
8677 C-----------------------------------------------------------------------
8678 C-----------------------------------------------------------------------
8679       double precision function sscalelip(r)
8680       double precision r,gamm
8681       include "COMMON.SPLITELE"
8682 C      if(r.lt.r_cut-rlamb) then
8683 C        sscale=1.0d0
8684 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8685 C        gamm=(r-(r_cut-rlamb))/rlamb
8686         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8687 C      else
8688 C        sscale=0d0
8689 C      endif
8690       return
8691       end
8692 C-----------------------------------------------------------------------
8693       double precision function sscagradlip(r)
8694       double precision r,gamm
8695       include "COMMON.SPLITELE"
8696 C     if(r.lt.r_cut-rlamb) then
8697 C        sscagrad=0.0d0
8698 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8699 C        gamm=(r-(r_cut-rlamb))/rlamb
8700         sscagradlip=r*(6*r-6.0d0)
8701 C      else
8702 C        sscagrad=0.0d0
8703 C      endif
8704       return
8705       end
8706
8707 C-----------------------------------------------------------------------
8708        subroutine set_shield_fac
8709       implicit real*8 (a-h,o-z)
8710       include 'DIMENSIONS'
8711       include 'COMMON.CHAIN'
8712       include 'COMMON.DERIV'
8713       include 'COMMON.IOUNITS'
8714       include 'COMMON.SHIELD'
8715       include 'COMMON.INTERACT'
8716 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8717       double precision div77_81/0.974996043d0/,
8718      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8719
8720 C the vector between center of side_chain and peptide group
8721        double precision pep_side(3),long,side_calf(3),
8722      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8723      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8724 C the line belowe needs to be changed for FGPROC>1
8725       do i=1,nres-1
8726       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8727       ishield_list(i)=0
8728 Cif there two consequtive dummy atoms there is no peptide group between them
8729 C the line below has to be changed for FGPROC>1
8730       VolumeTotal=0.0
8731       do k=1,nres
8732        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8733        dist_pep_side=0.0
8734        dist_side_calf=0.0
8735        do j=1,3
8736 C first lets set vector conecting the ithe side-chain with kth side-chain
8737       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8738 C      pep_side(j)=2.0d0
8739 C and vector conecting the side-chain with its proper calfa
8740       side_calf(j)=c(j,k+nres)-c(j,k)
8741 C      side_calf(j)=2.0d0
8742       pept_group(j)=c(j,i)-c(j,i+1)
8743 C lets have their lenght
8744       dist_pep_side=pep_side(j)**2+dist_pep_side
8745       dist_side_calf=dist_side_calf+side_calf(j)**2
8746       dist_pept_group=dist_pept_group+pept_group(j)**2
8747       enddo
8748        dist_pep_side=dsqrt(dist_pep_side)
8749        dist_pept_group=dsqrt(dist_pept_group)
8750        dist_side_calf=dsqrt(dist_side_calf)
8751       do j=1,3
8752         pep_side_norm(j)=pep_side(j)/dist_pep_side
8753         side_calf_norm(j)=dist_side_calf
8754       enddo
8755 C now sscale fraction
8756        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8757 C       print *,buff_shield,"buff"
8758 C now sscale
8759         if (sh_frac_dist.le.0.0) cycle
8760 C If we reach here it means that this side chain reaches the shielding sphere
8761 C Lets add him to the list for gradient
8762         ishield_list(i)=ishield_list(i)+1
8763 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8764 C this list is essential otherwise problem would be O3
8765         shield_list(ishield_list(i),i)=k
8766 C Lets have the sscale value
8767         if (sh_frac_dist.gt.1.0) then
8768          scale_fac_dist=1.0d0
8769          do j=1,3
8770          sh_frac_dist_grad(j)=0.0d0
8771          enddo
8772         else
8773          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8774      &                   *(2.0*sh_frac_dist-3.0d0)
8775          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8776      &                  /dist_pep_side/buff_shield*0.5
8777 C remember for the final gradient multiply sh_frac_dist_grad(j)
8778 C for side_chain by factor -2 !
8779          do j=1,3
8780          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8781 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8782 C     &                    sh_frac_dist_grad(j)
8783          enddo
8784         endif
8785 C        if ((i.eq.3).and.(k.eq.2)) then
8786 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8787 C     & ,"TU"
8788 C        endif
8789
8790 C this is what is now we have the distance scaling now volume...
8791       short=short_r_sidechain(itype(k))
8792       long=long_r_sidechain(itype(k))
8793       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8794 C now costhet_grad
8795 C       costhet=0.0d0
8796        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8797 C       costhet_fac=0.0d0
8798        do j=1,3
8799          costhet_grad(j)=costhet_fac*pep_side(j)
8800        enddo
8801 C remember for the final gradient multiply costhet_grad(j)
8802 C for side_chain by factor -2 !
8803 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8804 C pep_side0pept_group is vector multiplication
8805       pep_side0pept_group=0.0
8806       do j=1,3
8807       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8808       enddo
8809       cosalfa=(pep_side0pept_group/
8810      & (dist_pep_side*dist_side_calf))
8811       fac_alfa_sin=1.0-cosalfa**2
8812       fac_alfa_sin=dsqrt(fac_alfa_sin)
8813       rkprim=fac_alfa_sin*(long-short)+short
8814 C now costhet_grad
8815        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8816        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8817
8818        do j=1,3
8819          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8820      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8821      &*(long-short)/fac_alfa_sin*cosalfa/
8822      &((dist_pep_side*dist_side_calf))*
8823      &((side_calf(j))-cosalfa*
8824      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8825
8826         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8827      &*(long-short)/fac_alfa_sin*cosalfa
8828      &/((dist_pep_side*dist_side_calf))*
8829      &(pep_side(j)-
8830      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8831        enddo
8832
8833       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8834      &                    /VSolvSphere_div
8835      &                    *wshield
8836 C now the gradient...
8837 C grad_shield is gradient of Calfa for peptide groups
8838 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8839 C     &               costhet,cosphi
8840 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8841 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8842       do j=1,3
8843       grad_shield(j,i)=grad_shield(j,i)
8844 C gradient po skalowaniu
8845      &                +(sh_frac_dist_grad(j)
8846 C  gradient po costhet
8847      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8848      &-scale_fac_dist*(cosphi_grad_long(j))
8849      &/(1.0-cosphi) )*div77_81
8850      &*VofOverlap
8851 C grad_shield_side is Cbeta sidechain gradient
8852       grad_shield_side(j,ishield_list(i),i)=
8853      &        (sh_frac_dist_grad(j)*-2.0d0
8854      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8855      &       +scale_fac_dist*(cosphi_grad_long(j))
8856      &        *2.0d0/(1.0-cosphi))
8857      &        *div77_81*VofOverlap
8858
8859        grad_shield_loc(j,ishield_list(i),i)=
8860      &   scale_fac_dist*cosphi_grad_loc(j)
8861      &        *2.0d0/(1.0-cosphi)
8862      &        *div77_81*VofOverlap
8863       enddo
8864       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8865       enddo
8866       fac_shield(i)=VolumeTotal*div77_81+div4_81
8867 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8868       enddo
8869       return
8870       end
8871 C--------------------------------------------------------------------------
8872 C first for shielding is setting of function of side-chains
8873        subroutine set_shield_fac2
8874       implicit real*8 (a-h,o-z)
8875       include 'DIMENSIONS'
8876       include 'COMMON.CHAIN'
8877       include 'COMMON.DERIV'
8878       include 'COMMON.IOUNITS'
8879       include 'COMMON.SHIELD'
8880       include 'COMMON.INTERACT'
8881 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8882       double precision div77_81/0.974996043d0/,
8883      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8884
8885 C the vector between center of side_chain and peptide group
8886        double precision pep_side(3),long,side_calf(3),
8887      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8888      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8889 C the line belowe needs to be changed for FGPROC>1
8890       do i=1,nres-1
8891       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8892       ishield_list(i)=0
8893 Cif there two consequtive dummy atoms there is no peptide group between them
8894 C the line below has to be changed for FGPROC>1
8895       VolumeTotal=0.0
8896       do k=1,nres
8897        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8898        dist_pep_side=0.0
8899        dist_side_calf=0.0
8900        do j=1,3
8901 C first lets set vector conecting the ithe side-chain with kth side-chain
8902       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8903 C      pep_side(j)=2.0d0
8904 C and vector conecting the side-chain with its proper calfa
8905       side_calf(j)=c(j,k+nres)-c(j,k)
8906 C      side_calf(j)=2.0d0
8907       pept_group(j)=c(j,i)-c(j,i+1)
8908 C lets have their lenght
8909       dist_pep_side=pep_side(j)**2+dist_pep_side
8910       dist_side_calf=dist_side_calf+side_calf(j)**2
8911       dist_pept_group=dist_pept_group+pept_group(j)**2
8912       enddo
8913        dist_pep_side=dsqrt(dist_pep_side)
8914        dist_pept_group=dsqrt(dist_pept_group)
8915        dist_side_calf=dsqrt(dist_side_calf)
8916       do j=1,3
8917         pep_side_norm(j)=pep_side(j)/dist_pep_side
8918         side_calf_norm(j)=dist_side_calf
8919       enddo
8920 C now sscale fraction
8921        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8922 C       print *,buff_shield,"buff"
8923 C now sscale
8924         if (sh_frac_dist.le.0.0) cycle
8925 C If we reach here it means that this side chain reaches the shielding sphere
8926 C Lets add him to the list for gradient
8927         ishield_list(i)=ishield_list(i)+1
8928 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8929 C this list is essential otherwise problem would be O3
8930         shield_list(ishield_list(i),i)=k
8931 C Lets have the sscale value
8932         if (sh_frac_dist.gt.1.0) then
8933          scale_fac_dist=1.0d0
8934          do j=1,3
8935          sh_frac_dist_grad(j)=0.0d0
8936          enddo
8937         else
8938          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8939      &                   *(2.0d0*sh_frac_dist-3.0d0)
8940          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8941      &                  /dist_pep_side/buff_shield*0.5d0
8942 C remember for the final gradient multiply sh_frac_dist_grad(j)
8943 C for side_chain by factor -2 !
8944          do j=1,3
8945          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8946 C         sh_frac_dist_grad(j)=0.0d0
8947 C         scale_fac_dist=1.0d0
8948 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8949 C     &                    sh_frac_dist_grad(j)
8950          enddo
8951         endif
8952 C this is what is now we have the distance scaling now volume...
8953       short=short_r_sidechain(itype(k))
8954       long=long_r_sidechain(itype(k))
8955       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8956       sinthet=short/dist_pep_side*costhet
8957 C now costhet_grad
8958 C       costhet=0.6d0
8959 C       sinthet=0.8
8960        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8961 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8962 C     &             -short/dist_pep_side**2/costhet)
8963 C       costhet_fac=0.0d0
8964        do j=1,3
8965          costhet_grad(j)=costhet_fac*pep_side(j)
8966        enddo
8967 C remember for the final gradient multiply costhet_grad(j)
8968 C for side_chain by factor -2 !
8969 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8970 C pep_side0pept_group is vector multiplication
8971       pep_side0pept_group=0.0d0
8972       do j=1,3
8973       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8974       enddo
8975       cosalfa=(pep_side0pept_group/
8976      & (dist_pep_side*dist_side_calf))
8977       fac_alfa_sin=1.0d0-cosalfa**2
8978       fac_alfa_sin=dsqrt(fac_alfa_sin)
8979       rkprim=fac_alfa_sin*(long-short)+short
8980 C      rkprim=short
8981
8982 C now costhet_grad
8983        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8984 C       cosphi=0.6
8985        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8986        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8987      &      dist_pep_side**2)
8988 C       sinphi=0.8
8989        do j=1,3
8990          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8991      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8992      &*(long-short)/fac_alfa_sin*cosalfa/
8993      &((dist_pep_side*dist_side_calf))*
8994      &((side_calf(j))-cosalfa*
8995      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8996 C       cosphi_grad_long(j)=0.0d0
8997         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8998      &*(long-short)/fac_alfa_sin*cosalfa
8999      &/((dist_pep_side*dist_side_calf))*
9000      &(pep_side(j)-
9001      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9002 C       cosphi_grad_loc(j)=0.0d0
9003        enddo
9004 C      print *,sinphi,sinthet
9005       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9006      &                    /VSolvSphere_div
9007 C     &                    *wshield
9008 C now the gradient...
9009       do j=1,3
9010       grad_shield(j,i)=grad_shield(j,i)
9011 C gradient po skalowaniu
9012      &                +(sh_frac_dist_grad(j)*VofOverlap
9013 C  gradient po costhet
9014      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9015      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9016      &       sinphi/sinthet*costhet*costhet_grad(j)
9017      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9018      & )*wshield
9019 C grad_shield_side is Cbeta sidechain gradient
9020       grad_shield_side(j,ishield_list(i),i)=
9021      &        (sh_frac_dist_grad(j)*-2.0d0
9022      &        *VofOverlap
9023      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9024      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9025      &       sinphi/sinthet*costhet*costhet_grad(j)
9026      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9027      &       )*wshield
9028
9029        grad_shield_loc(j,ishield_list(i),i)=
9030      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9031      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9032      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9033      &        ))
9034      &        *wshield
9035       enddo
9036       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9037       enddo
9038       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9039 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9040 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9041       enddo
9042       return
9043       end
9044