source/cluster/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 'sizesclu.dat'
   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
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   106 continue
  53 C      write(iout,*) "shield_mode",shield_mode,ethetacnstr
  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
  61 C Calculate excluded-volume interaction energy between peptide groups
  62 C and side chains.
  63 C
  64       call escp(evdw2,evdw2_14)
  65 c
  66 c Calculate the bond-stretching energy
  67 c
  68       call ebond(estr)
  69 c      write (iout,*) "estr",estr
  70 C
  71 C Calculate the disulfide-bridge and other energy and the contributions
  72 C from other distance constraints.
  73 cd    print *,'Calling EHPB'
  74       call edis(ehpb)
  75 cd    print *,'EHPB exitted succesfully.'
  76 C
  77 C Calculate the virtual-bond-angle energy.
  78 C
  79       call ebend(ebe,ethetacnstr)
  80 cd    print *,'Bend energy finished.'
  81 C
  82 C Calculate the SC local energy.
  83 C
  84       call esc(escloc)
  85 cd    print *,'SCLOC energy finished.'
  86 C
  87 C Calculate the virtual-bond torsional energy.
  88 C
  89 cd    print *,'nterm=',nterm
  90       call etor(etors,edihcnstr,fact(1))
  91 C
  92 C 6/23/01 Calculate double-torsional energy
  93 C
  94       call etor_d(etors_d,fact(2))
  95 C
  96 C 21/5/07 Calculate local sicdechain correlation energy
  97 C
  98       call eback_sc_corr(esccor)
  99
 100       if (wliptran.gt.0) then
 101         call Eliptransfer(eliptran)
 102       endif
 103
 104       if (TUBElog.eq.1) then
 105       print *,"just before call"
 106         call calctube(Etube)
 107        print *,"just after call",etube
 108        elseif (TUBElog.eq.2) then
 109         call calctube2(Etube)
 110        elseif (TUBElog.eq.3) then
 111         call calcnano(Etube)
 112        else
 113        Etube=0.0d0
 114        endif
 115        write(iout,*), "Etube",etube
 116 C
 117 C 12/1/95 Multi-body terms
 118 C
 119       n_corr=0
 120       n_corr1=0
 121       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 122      &    .or. wturn6.gt.0.0d0) then
 123 c         print *,"calling multibody_eello"
 124          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 125 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 126 c         print *,ecorr,ecorr5,ecorr6,eturn6
 127       else
 128          ecorr=0.0d0
 129          ecorr5=0.0d0
 130          ecorr6=0.0d0
 131          eturn6=0.0d0
 132       endif
 133       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 134          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 135       endif
 136       write (iout,*) "ft(6)",fact(6),wliptran,eliptran
 137 #ifdef SPLITELE
 138       if (shield_mode.gt.0) then
 139       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 140      & +welec*fact(1)*ees
 141      & +fact(1)*wvdwpp*evdw1
 142      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 143      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 144      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 145      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 146      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 147      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 148      & +wliptran*eliptran+wtube*Etube
 149       else
 150       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 151      & +wvdwpp*evdw1
 152      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 153      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 154      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 155      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 156      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 157      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 158      & +wliptran*eliptran+wtube*Etube
 159       endif
 160 #else
 161       if (shield_mode.gt.0) then
 162       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 163      & +welec*fact(1)*(ees+evdw1)
 164      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 165      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 166      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 167      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 168      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 169      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 170      & +wliptran*eliptran+wtube*Etube
 171       else
 172       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 173      & +welec*fact(1)*(ees+evdw1)
 174      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 175      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 176      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 177      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 178      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 179      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 180      & +wliptran*eliptran+wtube*Etube
 181       endif
 182 #endif
 183
 184       energia(0)=etot
 185       energia(1)=evdw
 186 #ifdef SCP14
 187       energia(2)=evdw2-evdw2_14
 188       energia(17)=evdw2_14
 189 #else
 190       energia(2)=evdw2
 191       energia(17)=0.0d0
 192 #endif
 193 #ifdef SPLITELE
 194       energia(3)=ees
 195       energia(16)=evdw1
 196 #else
 197       energia(3)=ees+evdw1
 198       energia(16)=0.0d0
 199 #endif
 200       energia(4)=ecorr
 201       energia(5)=ecorr5
 202       energia(6)=ecorr6
 203       energia(7)=eel_loc
 204       energia(8)=eello_turn3
 205       energia(9)=eello_turn4
 206       energia(10)=eturn6
 207       energia(11)=ebe
 208       energia(12)=escloc
 209       energia(13)=etors
 210       energia(14)=etors_d
 211       energia(15)=ehpb
 212       energia(18)=estr
 213       energia(19)=esccor
 214       energia(20)=edihcnstr
 215       energia(21)=evdw_t
 216       energia(24)=ethetacnstr
 217       energia(22)=eliptran
 218       energia(25)=Etube
 219 c detecting NaNQ
 220 #ifdef ISNAN
 221 #ifdef AIX
 222       if (isnan(etot).ne.0) energia(0)=1.0d+99
 223 #else
 224       if (isnan(etot)) energia(0)=1.0d+99
 225 #endif
 226 #else
 227       i=0
 228 #ifdef WINPGI
 229       idumm=proc_proc(etot,i)
 230 #else
 231       call proc_proc(etot,i)
 232 #endif
 233       if(i.eq.1)energia(0)=1.0d+99
 234 #endif
 235 #ifdef MPL
 236 c     endif
 237 #endif
 238       if (calc_grad) then
 239 C
 240 C Sum up the components of the Cartesian gradient.
 241 C
 242 #ifdef SPLITELE
 243       do i=1,nct
 244         do j=1,3
 245       if (shield_mode.eq.0) then
 246           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 247      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 248      &                wbond*gradb(j,i)+
 249      &                wstrain*ghpbc(j,i)+
 250      &                wcorr*fact(3)*gradcorr(j,i)+
 251      &                wel_loc*fact(2)*gel_loc(j,i)+
 252      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 253      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 254      &                wcorr5*fact(4)*gradcorr5(j,i)+
 255      &                wcorr6*fact(5)*gradcorr6(j,i)+
 256      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 257      &                wsccor*fact(2)*gsccorc(j,i)
 258      &               +wliptran*gliptranc(j,i)
 259      &                +wtube*gg_tube(j,i)
 260
 261           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 262      &                  wbond*gradbx(j,i)+
 263      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 264      &                  wsccor*fact(2)*gsccorx(j,i)
 265      &                 +wliptran*gliptranx(j,i)
 266      &                +wtube*gg_tube_SC(j,i)
 267
 268         else
 269           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 270      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 271      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 272      &                wbond*gradb(j,i)+
 273      &                wstrain*ghpbc(j,i)+
 274      &                wcorr*fact(3)*gradcorr(j,i)+
 275      &                wel_loc*fact(2)*gel_loc(j,i)+
 276      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 277      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 278      &                wcorr5*fact(4)*gradcorr5(j,i)+
 279      &                wcorr6*fact(5)*gradcorr6(j,i)+
 280      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 281      &                wsccor*fact(2)*gsccorc(j,i)
 282      &               +wliptran*gliptranc(j,i)
 283      &                 +welec*gshieldc(j,i)
 284      &                 +welec*gshieldc_loc(j,i)
 285      &                 +wcorr*gshieldc_ec(j,i)
 286      &                 +wcorr*gshieldc_loc_ec(j,i)
 287      &                 +wturn3*gshieldc_t3(j,i)
 288      &                 +wturn3*gshieldc_loc_t3(j,i)
 289      &                 +wturn4*gshieldc_t4(j,i)
 290      &                 +wturn4*gshieldc_loc_t4(j,i)
 291      &                 +wel_loc*gshieldc_ll(j,i)
 292      &                 +wel_loc*gshieldc_loc_ll(j,i)
 293      &                +wtube*gg_tube(j,i)
 294
 295           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 296      &                 +fact(1)*wscp*gradx_scp(j,i)+
 297      &                  wbond*gradbx(j,i)+
 298      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 299      &                  wsccor*fact(2)*gsccorx(j,i)
 300      &                 +wliptran*gliptranx(j,i)
 301      &                 +welec*gshieldx(j,i)
 302      &                 +wcorr*gshieldx_ec(j,i)
 303      &                 +wturn3*gshieldx_t3(j,i)
 304      &                 +wturn4*gshieldx_t4(j,i)
 305      &                 +wel_loc*gshieldx_ll(j,i)
 306      &                +wtube*gg_tube_SC(j,i)
 307
 308
 309         endif
 310         enddo
 311 #else
 312        do i=1,nct
 313         do j=1,3
 314                 if (shield_mode.eq.0) then
 315           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 316      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 317      &                wbond*gradb(j,i)+
 318      &                wcorr*fact(3)*gradcorr(j,i)+
 319      &                wel_loc*fact(2)*gel_loc(j,i)+
 320      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 321      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 322      &                wcorr5*fact(4)*gradcorr5(j,i)+
 323      &                wcorr6*fact(5)*gradcorr6(j,i)+
 324      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 325      &                wsccor*fact(2)*gsccorc(j,i)
 326      &               +wliptran*gliptranc(j,i)
 327      &                +wtube*gg_tube(j,i)
 328
 329           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 330      &                  wbond*gradbx(j,i)+
 331      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 332      &                  wsccor*fact(1)*gsccorx(j,i)
 333      &                 +wliptran*gliptranx(j,i)
 334      &                +wtube*gg_tube_SC(j,i)
 335               else
 336           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 337      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 338      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 339      &                wbond*gradb(j,i)+
 340      &                wcorr*fact(3)*gradcorr(j,i)+
 341      &                wel_loc*fact(2)*gel_loc(j,i)+
 342      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 343      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 344      &                wcorr5*fact(4)*gradcorr5(j,i)+
 345      &                wcorr6*fact(5)*gradcorr6(j,i)+
 346      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 347      &                wsccor*fact(2)*gsccorc(j,i)
 348      &               +wliptran*gliptranc(j,i)
 349      &                +wtube*gg_tube(j,i)
 350
 351           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 352      &                  fact(1)*wscp*gradx_scp(j,i)+
 353      &                  wbond*gradbx(j,i)+
 354      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 355      &                  wsccor*fact(1)*gsccorx(j,i)
 356      &                 +wliptran*gliptranx(j,i)
 357      &                +wtube*gg_tube_SC(j,i)
 358          endif
 359         enddo
 360 #endif
 361       enddo
 362
 363
 364       do i=1,nres-3
 365         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 366      &   +wcorr5*fact(4)*g_corr5_loc(i)
 367      &   +wcorr6*fact(5)*g_corr6_loc(i)
 368      &   +wturn4*fact(3)*gel_loc_turn4(i)
 369      &   +wturn3*fact(2)*gel_loc_turn3(i)
 370      &   +wturn6*fact(5)*gel_loc_turn6(i)
 371      &   +wel_loc*fact(2)*gel_loc_loc(i)
 372 c     &   +wsccor*fact(1)*gsccor_loc(i)
 373 c ROZNICA Z WHAMem
 374       enddo
 375       endif
 376       if (dyn_ss) call dyn_set_nss
 377       return
 378       end
 379 C------------------------------------------------------------------------
 380       subroutine enerprint(energia,fact)
 381       implicit real*8 (a-h,o-z)
 382       include 'DIMENSIONS'
 383       include 'sizesclu.dat'
 384       include 'COMMON.IOUNITS'
 385       include 'COMMON.FFIELD'
 386       include 'COMMON.SBRIDGE'
 387       double precision energia(0:max_ene),fact(6)
 388       etot=energia(0)
 389       evdw=energia(1)+fact(6)*energia(21)
 390 #ifdef SCP14
 391       evdw2=energia(2)+energia(17)
 392 #else
 393       evdw2=energia(2)
 394 #endif
 395       ees=energia(3)
 396 #ifdef SPLITELE
 397       evdw1=energia(16)
 398 #endif
 399       ecorr=energia(4)
 400       ecorr5=energia(5)
 401       ecorr6=energia(6)
 402       eel_loc=energia(7)
 403       eello_turn3=energia(8)
 404       eello_turn4=energia(9)
 405       eello_turn6=energia(10)
 406       ebe=energia(11)
 407       escloc=energia(12)
 408       etors=energia(13)
 409       etors_d=energia(14)
 410       ehpb=energia(15)
 411       esccor=energia(19)
 412       edihcnstr=energia(20)
 413       estr=energia(18)
 414       ethetacnstr=energia(24)
 415       etube=energia(25)
 416 #ifdef SPLITELE
 417       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 418      &  wvdwpp,
 419      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 420      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 421      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 422      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 423      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 424      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,etube,wtube,
 425      & etot
 426    10 format (/'Virtual-chain energies:'//
 427      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 428      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 429      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 430      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 431      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 432      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 433      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 434      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 435      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 436      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 437      & ' (SS bridges & dist. cnstr.)'/
 438      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 439      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 440      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 441      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 442      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 443      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 444      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 445      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 446      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 447      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 448      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 449      & 'ETUBE=',1pE16.6,' WEIGHT=',1pD16.6,' (energy with nano)'/
 450      & 'ETOT=  ',1pE16.6,' (total)')
 451 #else
 452       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 453      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 454      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 455      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 456      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 457      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 458      &  edihcnstr,ethetacnstr,ebr*nss,etube,wtube,etot
 459    10 format (/'Virtual-chain energies:'//
 460      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 461      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 462      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 463      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 464      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 465      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 466      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 467      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 468      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 469      & ' (SS bridges & dist. cnstr.)'/
 470      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 471      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 472      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 473      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 474      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 475      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 476      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 477      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 478      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 479      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 480      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 481      & 'ETUBE=',1pE16.6,' WEIGHT=',1pD16.6,' (energy with nano)'/
 482      & 'ETOT=  ',1pE16.6,' (total)')
 483 #endif
 484       return
 485       end
 486 C-----------------------------------------------------------------------
 487       subroutine elj(evdw,evdw_t)
 488 C
 489 C This subroutine calculates the interaction energy of nonbonded side chains
 490 C assuming the LJ potential of interaction.
 491 C
 492       implicit real*8 (a-h,o-z)
 493       include 'DIMENSIONS'
 494       include 'sizesclu.dat'
 495       include "DIMENSIONS.COMPAR"
 496       parameter (accur=1.0d-10)
 497       include 'COMMON.GEO'
 498       include 'COMMON.VAR'
 499       include 'COMMON.LOCAL'
 500       include 'COMMON.CHAIN'
 501       include 'COMMON.DERIV'
 502       include 'COMMON.INTERACT'
 503       include 'COMMON.TORSION'
 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 DODANE Z WHAM
 513 c      do i=1,210
 514 c        do j=1,2
 515 c          eneps_temp(j,i)=0.0d0
 516 c        enddo
 517 c      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 WHAM
 554 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 555 c            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 'sizesclu.dat'
 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.IOUNITS'
 684       include 'COMMON.NAMES'
 685       dimension gg(3)
 686       logical scheck
 687       integer icant
 688       external icant
 689 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 690       evdw=0.0D0
 691       evdw_t=0.0d0
 692       do i=iatsc_s,iatsc_e
 693         itypi=iabs(itype(i))
 694         if (itypi.eq.ntyp1) cycle
 695         itypi1=iabs(itype(i+1))
 696         xi=c(1,nres+i)
 697         yi=c(2,nres+i)
 698         zi=c(3,nres+i)
 699 C
 700 C Calculate SC interaction energy.
 701 C
 702         do iint=1,nint_gr(i)
 703           do j=istart(i,iint),iend(i,iint)
 704             itypj=iabs(itype(j))
 705             if (itypj.eq.ntyp1) cycle
 706             xj=c(1,nres+j)-xi
 707             yj=c(2,nres+j)-yi
 708             zj=c(3,nres+j)-zi
 709             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 710             fac_augm=rrij**expon
 711             e_augm=augm(itypi,itypj)*fac_augm
 712             r_inv_ij=dsqrt(rrij)
 713             rij=1.0D0/r_inv_ij
 714             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 715             fac=r_shift_inv**expon
 716             e1=fac*fac*aa
 717             e2=fac*bb
 718             evdwij=e_augm+e1+e2
 719             ij=icant(itypi,itypj)
 720 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 721 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 722 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 723 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 724 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 725 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 726 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 727             if (bb.gt.0.0d0) then
 728               evdw=evdw+evdwij
 729             else
 730               evdw_t=evdw_t+evdwij
 731             endif
 732             if (calc_grad) then
 733 C
 734 C Calculate the components of the gradient in DC and X
 735 C
 736             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 737             gg(1)=xj*fac
 738             gg(2)=yj*fac
 739             gg(3)=zj*fac
 740             do k=1,3
 741               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 742               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 743             enddo
 744             do k=i,j-1
 745               do l=1,3
 746                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 747               enddo
 748             enddo
 749             endif
 750           enddo      ! j
 751         enddo        ! iint
 752       enddo          ! i
 753       if (calc_grad) then
 754       do i=1,nct
 755         do j=1,3
 756           gvdwc(j,i)=expon*gvdwc(j,i)
 757           gvdwx(j,i)=expon*gvdwx(j,i)
 758         enddo
 759       enddo
 760       endif
 761       return
 762       end
 763 C-----------------------------------------------------------------------------
 764       subroutine ebp(evdw,evdw_t)
 765 C
 766 C This subroutine calculates the interaction energy of nonbonded side chains
 767 C assuming the Berne-Pechukas potential of interaction.
 768 C
 769       implicit real*8 (a-h,o-z)
 770       include 'DIMENSIONS'
 771       include 'sizesclu.dat'
 772       include "DIMENSIONS.COMPAR"
 773       include 'COMMON.GEO'
 774       include 'COMMON.VAR'
 775       include 'COMMON.LOCAL'
 776       include 'COMMON.CHAIN'
 777       include 'COMMON.DERIV'
 778       include 'COMMON.NAMES'
 779       include 'COMMON.INTERACT'
 780       include 'COMMON.IOUNITS'
 781       include 'COMMON.CALC'
 782       common /srutu/ icall
 783 c     double precision rrsave(maxdim)
 784       logical lprn
 785       integer icant
 786       external icant
 787       evdw=0.0D0
 788       evdw_t=0.0d0
 789 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 790 c     if (icall.eq.0) then
 791 c       lprn=.true.
 792 c     else
 793         lprn=.false.
 794 c     endif
 795       ind=0
 796       do i=iatsc_s,iatsc_e
 797         itypi=iabs(itype(i))
 798         if (itypi.eq.ntyp1) cycle
 799         itypi1=iabs(itype(i+1))
 800         xi=c(1,nres+i)
 801         yi=c(2,nres+i)
 802         zi=c(3,nres+i)
 803         dxi=dc_norm(1,nres+i)
 804         dyi=dc_norm(2,nres+i)
 805         dzi=dc_norm(3,nres+i)
 806         dsci_inv=vbld_inv(i+nres)
 807 C
 808 C Calculate SC interaction energy.
 809 C
 810         do iint=1,nint_gr(i)
 811           do j=istart(i,iint),iend(i,iint)
 812             ind=ind+1
 813             itypj=iabs(itype(j))
 814             if (itypj.eq.ntyp1) cycle
 815             dscj_inv=vbld_inv(j+nres)
 816             chi1=chi(itypi,itypj)
 817             chi2=chi(itypj,itypi)
 818             chi12=chi1*chi2
 819             chip1=chip(itypi)
 820             chip2=chip(itypj)
 821             chip12=chip1*chip2
 822             alf1=alp(itypi)
 823             alf2=alp(itypj)
 824             alf12=0.5D0*(alf1+alf2)
 825 C For diagnostics only!!!
 826 c           chi1=0.0D0
 827 c           chi2=0.0D0
 828 c           chi12=0.0D0
 829 c           chip1=0.0D0
 830 c           chip2=0.0D0
 831 c           chip12=0.0D0
 832 c           alf1=0.0D0
 833 c           alf2=0.0D0
 834 c           alf12=0.0D0
 835             xj=c(1,nres+j)-xi
 836             yj=c(2,nres+j)-yi
 837             zj=c(3,nres+j)-zi
 838             dxj=dc_norm(1,nres+j)
 839             dyj=dc_norm(2,nres+j)
 840             dzj=dc_norm(3,nres+j)
 841             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 842 cd          if (icall.eq.0) then
 843 cd            rrsave(ind)=rrij
 844 cd          else
 845 cd            rrij=rrsave(ind)
 846 cd          endif
 847             rij=dsqrt(rrij)
 848 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 849             call sc_angular
 850 C Calculate whole angle-dependent part of epsilon and contributions
 851 C to its derivatives
 852             fac=(rrij*sigsq)**expon2
 853             e1=fac*fac*aa
 854             e2=fac*bb
 855             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 856             eps2der=evdwij*eps3rt
 857             eps3der=evdwij*eps2rt
 858             evdwij=evdwij*eps2rt*eps3rt
 859             ij=icant(itypi,itypj)
 860             aux=eps1*eps2rt**2*eps3rt**2
 861             if (bb.gt.0.0d0) then
 862               evdw=evdw+evdwij
 863             else
 864               evdw_t=evdw_t+evdwij
 865             endif
 866             if (calc_grad) then
 867             if (lprn) then
 868             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 869             epsi=bb**2/aa
 870 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 871 cd     &        restyp(itypi),i,restyp(itypj),j,
 872 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 873 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 874 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 875 cd     &        evdwij
 876             endif
 877 C Calculate gradient components.
 878             e1=e1*eps1*eps2rt**2*eps3rt**2
 879             fac=-expon*(e1+evdwij)
 880             sigder=fac/sigsq
 881             fac=rrij*fac
 882 C Calculate radial part of the gradient
 883             gg(1)=xj*fac
 884             gg(2)=yj*fac
 885             gg(3)=zj*fac
 886 C Calculate the angular part of the gradient and sum add the contributions
 887 C to the appropriate components of the Cartesian gradient.
 888             call sc_grad
 889             endif
 890           enddo      ! j
 891         enddo        ! iint
 892       enddo          ! i
 893 c     stop
 894       return
 895       end
 896 C-----------------------------------------------------------------------------
 897       subroutine egb(evdw,evdw_t)
 898 C
 899 C This subroutine calculates the interaction energy of nonbonded side chains
 900 C assuming the Gay-Berne potential of interaction.
 901 C
 902       implicit real*8 (a-h,o-z)
 903       include 'DIMENSIONS'
 904       include 'sizesclu.dat'
 905       include "DIMENSIONS.COMPAR"
 906       include 'COMMON.GEO'
 907       include 'COMMON.VAR'
 908       include 'COMMON.LOCAL'
 909       include 'COMMON.CHAIN'
 910       include 'COMMON.DERIV'
 911       include 'COMMON.NAMES'
 912       include 'COMMON.INTERACT'
 913       include 'COMMON.IOUNITS'
 914       include 'COMMON.CALC'
 915       include 'COMMON.SBRIDGE'
 916       logical lprn
 917       common /srutu/icall
 918       integer icant
 919       external icant
 920       integer xshift,yshift,zshift
 921       logical energy_dec /.false./
 922 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 923       evdw=0.0D0
 924       evdw_t=0.0d0
 925       lprn=.false.
 926 c      if (icall.gt.0) lprn=.true.
 927       ind=0
 928       do i=iatsc_s,iatsc_e
 929         itypi=iabs(itype(i))
 930         if (itypi.eq.ntyp1) cycle
 931         itypi1=iabs(itype(i+1))
 932         xi=c(1,nres+i)
 933         yi=c(2,nres+i)
 934         zi=c(3,nres+i)
 935           xi=mod(xi,boxxsize)
 936           if (xi.lt.0) xi=xi+boxxsize
 937           yi=mod(yi,boxysize)
 938           if (yi.lt.0) yi=yi+boxysize
 939           zi=mod(zi,boxzsize)
 940           if (zi.lt.0) zi=zi+boxzsize
 941        if ((zi.gt.bordlipbot)
 942      &.and.(zi.lt.bordliptop)) then
 943 C the energy transfer exist
 944         if (zi.lt.buflipbot) then
 945 C what fraction I am in
 946          fracinbuf=1.0d0-
 947      &        ((zi-bordlipbot)/lipbufthick)
 948 C lipbufthick is thickenes of lipid buffore
 949          sslipi=sscalelip(fracinbuf)
 950          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 951         elseif (zi.gt.bufliptop) then
 952          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 953          sslipi=sscalelip(fracinbuf)
 954          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 955         else
 956          sslipi=1.0d0
 957          ssgradlipi=0.0
 958         endif
 959        else
 960          sslipi=0.0d0
 961          ssgradlipi=0.0
 962        endif
 963         dxi=dc_norm(1,nres+i)
 964         dyi=dc_norm(2,nres+i)
 965         dzi=dc_norm(3,nres+i)
 966         dsci_inv=vbld_inv(i+nres)
 967 C
 968 C Calculate SC interaction energy.
 969 C
 970         do iint=1,nint_gr(i)
 971           do j=istart(i,iint),iend(i,iint)
 972             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 973
 974 c              write(iout,*) "PRZED ZWYKLE", evdwij
 975               call dyn_ssbond_ene(i,j,evdwij)
 976 c              write(iout,*) "PO ZWYKLE", evdwij
 977
 978               evdw=evdw+evdwij
 979               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 980      &                        'evdw',i,j,evdwij,' ss'
 981 C triple bond artifac removal
 982              do k=j+1,iend(i,iint)
 983 C search over all next residues
 984               if (dyn_ss_mask(k)) then
 985 C check if they are cysteins
 986 C              write(iout,*) 'k=',k
 987
 988 c              write(iout,*) "PRZED TRI", evdwij
 989                evdwij_przed_tri=evdwij
 990               call triple_ssbond_ene(i,j,k,evdwij)
 991 c               if(evdwij_przed_tri.ne.evdwij) then
 992 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
 993 c               endif
 994
 995 c              write(iout,*) "PO TRI", evdwij
 996 C call the energy function that removes the artifical triple disulfide
 997 C bond the soubroutine is located in ssMD.F
 998               evdw=evdw+evdwij
 999               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1000      &                        'evdw',i,j,evdwij,'tss'
1001               endif!dyn_ss_mask(k)
1002              enddo! k
1003             ELSE
1004             ind=ind+1
1005             itypj=iabs(itype(j))
1006             if (itypj.eq.ntyp1) cycle
1007             dscj_inv=vbld_inv(j+nres)
1008             sig0ij=sigma(itypi,itypj)
1009             chi1=chi(itypi,itypj)
1010             chi2=chi(itypj,itypi)
1011             chi12=chi1*chi2
1012             chip1=chip(itypi)
1013             chip2=chip(itypj)
1014             chip12=chip1*chip2
1015             alf1=alp(itypi)
1016             alf2=alp(itypj)
1017             alf12=0.5D0*(alf1+alf2)
1018 C For diagnostics only!!!
1019 c           chi1=0.0D0
1020 c           chi2=0.0D0
1021 c           chi12=0.0D0
1022 c           chip1=0.0D0
1023 c           chip2=0.0D0
1024 c           chip12=0.0D0
1025 c           alf1=0.0D0
1026 c           alf2=0.0D0
1027 c           alf12=0.0D0
1028             xj=c(1,nres+j)
1029             yj=c(2,nres+j)
1030             zj=c(3,nres+j)
1031           xj=mod(xj,boxxsize)
1032           if (xj.lt.0) xj=xj+boxxsize
1033           yj=mod(yj,boxysize)
1034           if (yj.lt.0) yj=yj+boxysize
1035           zj=mod(zj,boxzsize)
1036           if (zj.lt.0) zj=zj+boxzsize
1037        if ((zj.gt.bordlipbot)
1038      &.and.(zj.lt.bordliptop)) then
1039 C the energy transfer exist
1040         if (zj.lt.buflipbot) then
1041 C what fraction I am in
1042          fracinbuf=1.0d0-
1043      &        ((zj-bordlipbot)/lipbufthick)
1044 C lipbufthick is thickenes of lipid buffore
1045          sslipj=sscalelip(fracinbuf)
1046          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1047         elseif (zj.gt.bufliptop) then
1048          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1049          sslipj=sscalelip(fracinbuf)
1050          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1051         else
1052          sslipj=1.0d0
1053          ssgradlipj=0.0
1054         endif
1055        else
1056          sslipj=0.0d0
1057          ssgradlipj=0.0
1058        endif
1059       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1060      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1061       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1062      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1063 C      write(iout,*) "czy jest 0", bb-bb_lip(itypi,itypj),
1064 C     & bb-bb_aq(itypi,itypj)
1065       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1066       xj_safe=xj
1067       yj_safe=yj
1068       zj_safe=zj
1069       subchap=0
1070       do xshift=-1,1
1071       do yshift=-1,1
1072       do zshift=-1,1
1073           xj=xj_safe+xshift*boxxsize
1074           yj=yj_safe+yshift*boxysize
1075           zj=zj_safe+zshift*boxzsize
1076           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1077           if(dist_temp.lt.dist_init) then
1078             dist_init=dist_temp
1079             xj_temp=xj
1080             yj_temp=yj
1081             zj_temp=zj
1082             subchap=1
1083           endif
1084        enddo
1085        enddo
1086        enddo
1087        if (subchap.eq.1) then
1088           xj=xj_temp-xi
1089           yj=yj_temp-yi
1090           zj=zj_temp-zi
1091        else
1092           xj=xj_safe-xi
1093           yj=yj_safe-yi
1094           zj=zj_safe-zi
1095        endif
1096             dxj=dc_norm(1,nres+j)
1097             dyj=dc_norm(2,nres+j)
1098             dzj=dc_norm(3,nres+j)
1099 c            write (iout,*) i,j,xj,yj,zj
1100             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1101             rij=dsqrt(rrij)
1102             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1103             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1104             if (sss.le.0.0d0) cycle
1105 C Calculate angle-dependent terms of energy and contributions to their
1106 C derivatives.
1107             call sc_angular
1108             sigsq=1.0D0/sigsq
1109             sig=sig0ij*dsqrt(sigsq)
1110             rij_shift=1.0D0/rij-sig+sig0ij
1111 C I hate to put IF's in the loops, but here don't have another choice!!!!
1112             if (rij_shift.le.0.0D0) then
1113               evdw=1.0D20
1114               return
1115             endif
1116             sigder=-sig*sigsq
1117 c---------------------------------------------------------------
1118             rij_shift=1.0D0/rij_shift
1119             fac=rij_shift**expon
1120             e1=fac*fac*aa
1121             e2=fac*bb
1122             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1123             eps2der=evdwij*eps3rt
1124             eps3der=evdwij*eps2rt
1125             evdwij=evdwij*eps2rt*eps3rt
1126             if (bb.gt.0) then
1127               evdw=evdw+evdwij*sss
1128             else
1129               evdw_t=evdw_t+evdwij*sss
1130             endif
1131             ij=icant(itypi,itypj)
1132             aux=eps1*eps2rt**2*eps3rt**2
1133 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1134 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1135 c     &         aux*e2/eps(itypi,itypj)
1136 c            if (lprn) then
1137             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1138             epsi=bb**2/aa
1139 C#define DEBUG
1140 #ifdef DEBUG
1141 C            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1142 C     &        restyp(itypi),i,restyp(itypj),j,
1143 C     &        epsi,sigm,chi1,chi2,chip1,chip2,
1144 C     &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1145 C     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1146 C     &        evdwij
1147              write (iout,*) "pratial sum", evdw,evdw_t,e1,e2,fac,aa
1148 #endif
1149 C#undef DEBUG
1150 c            endif
1151             if (calc_grad) then
1152 C Calculate gradient components.
1153             e1=e1*eps1*eps2rt**2*eps3rt**2
1154             fac=-expon*(e1+evdwij)*rij_shift
1155             sigder=fac*sigder
1156             fac=rij*fac
1157             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1158             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1159      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1160      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1161      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1162             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1163             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1164 C Calculate the radial part of the gradient
1165             gg(1)=xj*fac
1166             gg(2)=yj*fac
1167             gg(3)=zj*fac
1168 C Calculate angular part of the gradient.
1169             call sc_grad
1170             endif
1171             ENDIF    ! dyn_ss
1172           enddo      ! j
1173         enddo        ! iint
1174       enddo          ! i
1175       return
1176       end
1177 C-----------------------------------------------------------------------------
1178       subroutine egbv(evdw,evdw_t)
1179 C
1180 C This subroutine calculates the interaction energy of nonbonded side chains
1181 C assuming the Gay-Berne-Vorobjev potential of interaction.
1182 C
1183       implicit real*8 (a-h,o-z)
1184       include 'DIMENSIONS'
1185       include 'sizesclu.dat'
1186       include "DIMENSIONS.COMPAR"
1187       include 'COMMON.GEO'
1188       include 'COMMON.VAR'
1189       include 'COMMON.LOCAL'
1190       include 'COMMON.CHAIN'
1191       include 'COMMON.DERIV'
1192       include 'COMMON.NAMES'
1193       include 'COMMON.INTERACT'
1194       include 'COMMON.IOUNITS'
1195       include 'COMMON.CALC'
1196       common /srutu/ icall
1197       logical lprn
1198       integer icant
1199       external icant
1200       evdw=0.0D0
1201       evdw_t=0.0d0
1202 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1203       evdw=0.0D0
1204       lprn=.false.
1205 c      if (icall.gt.0) lprn=.true.
1206       ind=0
1207       do i=iatsc_s,iatsc_e
1208         itypi=iabs(itype(i))
1209         if (itypi.eq.ntyp1) cycle
1210         itypi1=iabs(itype(i+1))
1211         xi=c(1,nres+i)
1212         yi=c(2,nres+i)
1213         zi=c(3,nres+i)
1214         dxi=dc_norm(1,nres+i)
1215         dyi=dc_norm(2,nres+i)
1216         dzi=dc_norm(3,nres+i)
1217         dsci_inv=vbld_inv(i+nres)
1218 C returning the ith atom to box
1219           xi=mod(xi,boxxsize)
1220           if (xi.lt.0) xi=xi+boxxsize
1221           yi=mod(yi,boxysize)
1222           if (yi.lt.0) yi=yi+boxysize
1223           zi=mod(zi,boxzsize)
1224           if (zi.lt.0) zi=zi+boxzsize
1225        if ((zi.gt.bordlipbot)
1226      &.and.(zi.lt.bordliptop)) then
1227 C the energy transfer exist
1228         if (zi.lt.buflipbot) then
1229 C what fraction I am in
1230          fracinbuf=1.0d0-
1231      &        ((zi-bordlipbot)/lipbufthick)
1232 C lipbufthick is thickenes of lipid buffore
1233          sslipi=sscalelip(fracinbuf)
1234          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1235         elseif (zi.gt.bufliptop) then
1236          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1237          sslipi=sscalelip(fracinbuf)
1238          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1239         else
1240          sslipi=1.0d0
1241          ssgradlipi=0.0
1242         endif
1243        else
1244          sslipi=0.0d0
1245          ssgradlipi=0.0
1246        endif
1247 C
1248 C Calculate SC interaction energy.
1249 C
1250         do iint=1,nint_gr(i)
1251           do j=istart(i,iint),iend(i,iint)
1252             ind=ind+1
1253             itypj=iabs(itype(j))
1254             if (itypj.eq.ntyp1) cycle
1255             dscj_inv=vbld_inv(j+nres)
1256             sig0ij=sigma(itypi,itypj)
1257             r0ij=r0(itypi,itypj)
1258             chi1=chi(itypi,itypj)
1259             chi2=chi(itypj,itypi)
1260             chi12=chi1*chi2
1261             chip1=chip(itypi)
1262             chip2=chip(itypj)
1263             chip12=chip1*chip2
1264             alf1=alp(itypi)
1265             alf2=alp(itypj)
1266             alf12=0.5D0*(alf1+alf2)
1267 C For diagnostics only!!!
1268 c           chi1=0.0D0
1269 c           chi2=0.0D0
1270 c           chi12=0.0D0
1271 c           chip1=0.0D0
1272 c           chip2=0.0D0
1273 c           chip12=0.0D0
1274 c           alf1=0.0D0
1275 c           alf2=0.0D0
1276 c           alf12=0.0D0
1277             xj=c(1,nres+j)
1278             yj=c(2,nres+j)
1279             zj=c(3,nres+j)
1280 C returning jth atom to box
1281           xj=mod(xj,boxxsize)
1282           if (xj.lt.0) xj=xj+boxxsize
1283           yj=mod(yj,boxysize)
1284           if (yj.lt.0) yj=yj+boxysize
1285           zj=mod(zj,boxzsize)
1286           if (zj.lt.0) zj=zj+boxzsize
1287        if ((zj.gt.bordlipbot)
1288      &.and.(zj.lt.bordliptop)) then
1289 C the energy transfer exist
1290         if (zj.lt.buflipbot) then
1291 C what fraction I am in
1292          fracinbuf=1.0d0-
1293      &        ((zj-bordlipbot)/lipbufthick)
1294 C lipbufthick is thickenes of lipid buffore
1295          sslipj=sscalelip(fracinbuf)
1296          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1297         elseif (zj.gt.bufliptop) then
1298          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1299          sslipj=sscalelip(fracinbuf)
1300          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1301         else
1302          sslipj=1.0d0
1303          ssgradlipj=0.0
1304         endif
1305        else
1306          sslipj=0.0d0
1307          ssgradlipj=0.0
1308        endif
1309       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1310      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1311       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1312      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1313 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1314 C checking the distance
1315       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1316       xj_safe=xj
1317       yj_safe=yj
1318       zj_safe=zj
1319       subchap=0
1320 C finding the closest
1321       do xshift=-1,1
1322       do yshift=-1,1
1323       do zshift=-1,1
1324           xj=xj_safe+xshift*boxxsize
1325           yj=yj_safe+yshift*boxysize
1326           zj=zj_safe+zshift*boxzsize
1327           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1328           if(dist_temp.lt.dist_init) then
1329             dist_init=dist_temp
1330             xj_temp=xj
1331             yj_temp=yj
1332             zj_temp=zj
1333             subchap=1
1334           endif
1335        enddo
1336        enddo
1337        enddo
1338        if (subchap.eq.1) then
1339           xj=xj_temp-xi
1340           yj=yj_temp-yi
1341           zj=zj_temp-zi
1342        else
1343           xj=xj_safe-xi
1344           yj=yj_safe-yi
1345           zj=zj_safe-zi
1346        endif
1347             dxj=dc_norm(1,nres+j)
1348             dyj=dc_norm(2,nres+j)
1349             dzj=dc_norm(3,nres+j)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351             rij=dsqrt(rrij)
1352 C Calculate angle-dependent terms of energy and contributions to their
1353 C derivatives.
1354             call sc_angular
1355             sigsq=1.0D0/sigsq
1356             sig=sig0ij*dsqrt(sigsq)
1357             rij_shift=1.0D0/rij-sig+r0ij
1358 C I hate to put IF's in the loops, but here don't have another choice!!!!
1359             if (rij_shift.le.0.0D0) then
1360               evdw=1.0D20
1361               return
1362             endif
1363             sigder=-sig*sigsq
1364 c---------------------------------------------------------------
1365             rij_shift=1.0D0/rij_shift
1366             fac=rij_shift**expon
1367             e1=fac*fac*aa
1368             e2=fac*bb
1369             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1370             eps2der=evdwij*eps3rt
1371             eps3der=evdwij*eps2rt
1372             fac_augm=rrij**expon
1373             e_augm=augm(itypi,itypj)*fac_augm
1374             evdwij=evdwij*eps2rt*eps3rt
1375             if (bb.gt.0.0d0) then
1376               evdw=evdw+evdwij+e_augm
1377             else
1378               evdw_t=evdw_t+evdwij+e_augm
1379             endif
1380             ij=icant(itypi,itypj)
1381             aux=eps1*eps2rt**2*eps3rt**2
1382 c            if (lprn) then
1383 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1384 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1385 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1386 c     &        restyp(itypi),i,restyp(itypj),j,
1387 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1388 c     &        chi1,chi2,chip1,chip2,
1389 c     &        eps1,eps2rt**2,eps3rt**2,
1390 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1391 c     &        evdwij+e_augm
1392 c            endif
1393             if (calc_grad) then
1394 C Calculate gradient components.
1395             e1=e1*eps1*eps2rt**2*eps3rt**2
1396             fac=-expon*(e1+evdwij)*rij_shift
1397             sigder=fac*sigder
1398             fac=rij*fac-2*expon*rrij*e_augm
1399 C Calculate the radial part of the gradient
1400             gg(1)=xj*fac
1401             gg(2)=yj*fac
1402             gg(3)=zj*fac
1403 C Calculate angular part of the gradient.
1404             call sc_grad
1405             endif
1406           enddo      ! j
1407         enddo        ! iint
1408       enddo          ! i
1409       return
1410       end
1411 C-----------------------------------------------------------------------------
1412       subroutine sc_angular
1413 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1414 C om12. Called by ebp, egb, and egbv.
1415       implicit none
1416       include 'COMMON.CALC'
1417       erij(1)=xj*rij
1418       erij(2)=yj*rij
1419       erij(3)=zj*rij
1420       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1421       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1422       om12=dxi*dxj+dyi*dyj+dzi*dzj
1423       chiom12=chi12*om12
1424 C Calculate eps1(om12) and its derivative in om12
1425       faceps1=1.0D0-om12*chiom12
1426       faceps1_inv=1.0D0/faceps1
1427       eps1=dsqrt(faceps1_inv)
1428 C Following variable is eps1*deps1/dom12
1429       eps1_om12=faceps1_inv*chiom12
1430 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1431 C and om12.
1432       om1om2=om1*om2
1433       chiom1=chi1*om1
1434       chiom2=chi2*om2
1435       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1436       sigsq=1.0D0-facsig*faceps1_inv
1437       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1438       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1439       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1440 C Calculate eps2 and its derivatives in om1, om2, and om12.
1441       chipom1=chip1*om1
1442       chipom2=chip2*om2
1443       chipom12=chip12*om12
1444       facp=1.0D0-om12*chipom12
1445       facp_inv=1.0D0/facp
1446       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1447 C Following variable is the square root of eps2
1448       eps2rt=1.0D0-facp1*facp_inv
1449 C Following three variables are the derivatives of the square root of eps
1450 C in om1, om2, and om12.
1451       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1452       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1453       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1454 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1455       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1456 C Calculate whole angle-dependent part of epsilon and contributions
1457 C to its derivatives
1458       return
1459       end
1460 C----------------------------------------------------------------------------
1461       subroutine sc_grad
1462       implicit real*8 (a-h,o-z)
1463       include 'DIMENSIONS'
1464       include 'sizesclu.dat'
1465       include 'COMMON.CHAIN'
1466       include 'COMMON.DERIV'
1467       include 'COMMON.CALC'
1468       double precision dcosom1(3),dcosom2(3)
1469       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1470       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1471       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1472      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1473       do k=1,3
1474         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1475         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1476       enddo
1477       do k=1,3
1478         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1479       enddo
1480       do k=1,3
1481         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1482      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1483      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1484         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipi(k)
1485      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1486      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1487       enddo
1488 C
1489 C Calculate the components of the gradient in DC and X
1490 C
1491       do k=i,j-1
1492         do l=1,3
1493           gvdwc(l,k)=gvdwc(l,k)+gg(l)+gg_lipi(l)
1494         enddo
1495       enddo
1496       do l=1,3
1497          gvdwc(l,j)=gvdwc(l,j)+gg_lipj(l)
1498       enddo
1499       return
1500       end
1501 c------------------------------------------------------------------------------
1502       subroutine vec_and_deriv
1503       implicit real*8 (a-h,o-z)
1504       include 'DIMENSIONS'
1505       include 'sizesclu.dat'
1506       include 'COMMON.IOUNITS'
1507       include 'COMMON.GEO'
1508       include 'COMMON.VAR'
1509       include 'COMMON.LOCAL'
1510       include 'COMMON.CHAIN'
1511       include 'COMMON.VECTORS'
1512       include 'COMMON.DERIV'
1513       include 'COMMON.INTERACT'
1514       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1515 C Compute the local reference systems. For reference system (i), the
1516 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1517 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1518       do i=1,nres-1
1519 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1520           if (i.eq.nres-1) then
1521 C Case of the last full residue
1522 C Compute the Z-axis
1523             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1524             costh=dcos(pi-theta(nres))
1525             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1526             do k=1,3
1527               uz(k,i)=fac*uz(k,i)
1528             enddo
1529             if (calc_grad) then
1530 C Compute the derivatives of uz
1531             uzder(1,1,1)= 0.0d0
1532             uzder(2,1,1)=-dc_norm(3,i-1)
1533             uzder(3,1,1)= dc_norm(2,i-1)
1534             uzder(1,2,1)= dc_norm(3,i-1)
1535             uzder(2,2,1)= 0.0d0
1536             uzder(3,2,1)=-dc_norm(1,i-1)
1537             uzder(1,3,1)=-dc_norm(2,i-1)
1538             uzder(2,3,1)= dc_norm(1,i-1)
1539             uzder(3,3,1)= 0.0d0
1540             uzder(1,1,2)= 0.0d0
1541             uzder(2,1,2)= dc_norm(3,i)
1542             uzder(3,1,2)=-dc_norm(2,i)
1543             uzder(1,2,2)=-dc_norm(3,i)
1544             uzder(2,2,2)= 0.0d0
1545             uzder(3,2,2)= dc_norm(1,i)
1546             uzder(1,3,2)= dc_norm(2,i)
1547             uzder(2,3,2)=-dc_norm(1,i)
1548             uzder(3,3,2)= 0.0d0
1549             endif
1550 C Compute the Y-axis
1551             facy=fac
1552             do k=1,3
1553               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1554             enddo
1555             if (calc_grad) then
1556 C Compute the derivatives of uy
1557             do j=1,3
1558               do k=1,3
1559                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1560      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1561                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1562               enddo
1563               uyder(j,j,1)=uyder(j,j,1)-costh
1564               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1565             enddo
1566             do j=1,2
1567               do k=1,3
1568                 do l=1,3
1569                   uygrad(l,k,j,i)=uyder(l,k,j)
1570                   uzgrad(l,k,j,i)=uzder(l,k,j)
1571                 enddo
1572               enddo
1573             enddo
1574             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1575             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1576             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1577             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1578             endif
1579           else
1580 C Other residues
1581 C Compute the Z-axis
1582             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1583             costh=dcos(pi-theta(i+2))
1584             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1585             do k=1,3
1586               uz(k,i)=fac*uz(k,i)
1587             enddo
1588             if (calc_grad) then
1589 C Compute the derivatives of uz
1590             uzder(1,1,1)= 0.0d0
1591             uzder(2,1,1)=-dc_norm(3,i+1)
1592             uzder(3,1,1)= dc_norm(2,i+1)
1593             uzder(1,2,1)= dc_norm(3,i+1)
1594             uzder(2,2,1)= 0.0d0
1595             uzder(3,2,1)=-dc_norm(1,i+1)
1596             uzder(1,3,1)=-dc_norm(2,i+1)
1597             uzder(2,3,1)= dc_norm(1,i+1)
1598             uzder(3,3,1)= 0.0d0
1599             uzder(1,1,2)= 0.0d0
1600             uzder(2,1,2)= dc_norm(3,i)
1601             uzder(3,1,2)=-dc_norm(2,i)
1602             uzder(1,2,2)=-dc_norm(3,i)
1603             uzder(2,2,2)= 0.0d0
1604             uzder(3,2,2)= dc_norm(1,i)
1605             uzder(1,3,2)= dc_norm(2,i)
1606             uzder(2,3,2)=-dc_norm(1,i)
1607             uzder(3,3,2)= 0.0d0
1608             endif
1609 C Compute the Y-axis
1610             facy=fac
1611             do k=1,3
1612               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1613             enddo
1614             if (calc_grad) then
1615 C Compute the derivatives of uy
1616             do j=1,3
1617               do k=1,3
1618                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1619      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1620                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1621               enddo
1622               uyder(j,j,1)=uyder(j,j,1)-costh
1623               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1624             enddo
1625             do j=1,2
1626               do k=1,3
1627                 do l=1,3
1628                   uygrad(l,k,j,i)=uyder(l,k,j)
1629                   uzgrad(l,k,j,i)=uzder(l,k,j)
1630                 enddo
1631               enddo
1632             enddo
1633             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1634             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1635             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1636             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1637           endif
1638           endif
1639       enddo
1640       if (calc_grad) then
1641       do i=1,nres-1
1642         vbld_inv_temp(1)=vbld_inv(i+1)
1643         if (i.lt.nres-1) then
1644           vbld_inv_temp(2)=vbld_inv(i+2)
1645         else
1646           vbld_inv_temp(2)=vbld_inv(i)
1647         endif
1648         do j=1,2
1649           do k=1,3
1650             do l=1,3
1651               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1652               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1653             enddo
1654           enddo
1655         enddo
1656       enddo
1657       endif
1658       return
1659       end
1660 C-----------------------------------------------------------------------------
1661       subroutine vec_and_deriv_test
1662       implicit real*8 (a-h,o-z)
1663       include 'DIMENSIONS'
1664       include 'sizesclu.dat'
1665       include 'COMMON.IOUNITS'
1666       include 'COMMON.GEO'
1667       include 'COMMON.VAR'
1668       include 'COMMON.LOCAL'
1669       include 'COMMON.CHAIN'
1670       include 'COMMON.VECTORS'
1671       dimension uyder(3,3,2),uzder(3,3,2)
1672 C Compute the local reference systems. For reference system (i), the
1673 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1674 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1675       do i=1,nres-1
1676           if (i.eq.nres-1) then
1677 C Case of the last full residue
1678 C Compute the Z-axis
1679             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1680             costh=dcos(pi-theta(nres))
1681             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1682 c            write (iout,*) 'fac',fac,
1683 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1684             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1685             do k=1,3
1686               uz(k,i)=fac*uz(k,i)
1687             enddo
1688 C Compute the derivatives of uz
1689             uzder(1,1,1)= 0.0d0
1690             uzder(2,1,1)=-dc_norm(3,i-1)
1691             uzder(3,1,1)= dc_norm(2,i-1)
1692             uzder(1,2,1)= dc_norm(3,i-1)
1693             uzder(2,2,1)= 0.0d0
1694             uzder(3,2,1)=-dc_norm(1,i-1)
1695             uzder(1,3,1)=-dc_norm(2,i-1)
1696             uzder(2,3,1)= dc_norm(1,i-1)
1697             uzder(3,3,1)= 0.0d0
1698             uzder(1,1,2)= 0.0d0
1699             uzder(2,1,2)= dc_norm(3,i)
1700             uzder(3,1,2)=-dc_norm(2,i)
1701             uzder(1,2,2)=-dc_norm(3,i)
1702             uzder(2,2,2)= 0.0d0
1703             uzder(3,2,2)= dc_norm(1,i)
1704             uzder(1,3,2)= dc_norm(2,i)
1705             uzder(2,3,2)=-dc_norm(1,i)
1706             uzder(3,3,2)= 0.0d0
1707 C Compute the Y-axis
1708             do k=1,3
1709               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1710             enddo
1711             facy=fac
1712             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1713      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1714      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1715             do k=1,3
1716 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1717               uy(k,i)=
1718 c     &        facy*(
1719      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1720      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1721 c     &        )
1722             enddo
1723 c            write (iout,*) 'facy',facy,
1724 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1725             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1726             do k=1,3
1727               uy(k,i)=facy*uy(k,i)
1728             enddo
1729 C Compute the derivatives of uy
1730             do j=1,3
1731               do k=1,3
1732                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1733      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1734                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1735               enddo
1736 c              uyder(j,j,1)=uyder(j,j,1)-costh
1737 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1738               uyder(j,j,1)=uyder(j,j,1)
1739      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1740               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1741      &          +uyder(j,j,2)
1742             enddo
1743             do j=1,2
1744               do k=1,3
1745                 do l=1,3
1746                   uygrad(l,k,j,i)=uyder(l,k,j)
1747                   uzgrad(l,k,j,i)=uzder(l,k,j)
1748                 enddo
1749               enddo
1750             enddo
1751             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1752             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1753             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1754             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1755           else
1756 C Other residues
1757 C Compute the Z-axis
1758             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1759             costh=dcos(pi-theta(i+2))
1760             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1761             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1762             do k=1,3
1763               uz(k,i)=fac*uz(k,i)
1764             enddo
1765 C Compute the derivatives of uz
1766             uzder(1,1,1)= 0.0d0
1767             uzder(2,1,1)=-dc_norm(3,i+1)
1768             uzder(3,1,1)= dc_norm(2,i+1)
1769             uzder(1,2,1)= dc_norm(3,i+1)
1770             uzder(2,2,1)= 0.0d0
1771             uzder(3,2,1)=-dc_norm(1,i+1)
1772             uzder(1,3,1)=-dc_norm(2,i+1)
1773             uzder(2,3,1)= dc_norm(1,i+1)
1774             uzder(3,3,1)= 0.0d0
1775             uzder(1,1,2)= 0.0d0
1776             uzder(2,1,2)= dc_norm(3,i)
1777             uzder(3,1,2)=-dc_norm(2,i)
1778             uzder(1,2,2)=-dc_norm(3,i)
1779             uzder(2,2,2)= 0.0d0
1780             uzder(3,2,2)= dc_norm(1,i)
1781             uzder(1,3,2)= dc_norm(2,i)
1782             uzder(2,3,2)=-dc_norm(1,i)
1783             uzder(3,3,2)= 0.0d0
1784 C Compute the Y-axis
1785             facy=fac
1786             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1787      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1788      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1789             do k=1,3
1790 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1791               uy(k,i)=
1792 c     &        facy*(
1793      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1794      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1795 c     &        )
1796             enddo
1797 c            write (iout,*) 'facy',facy,
1798 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1799             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1800             do k=1,3
1801               uy(k,i)=facy*uy(k,i)
1802             enddo
1803 C Compute the derivatives of uy
1804             do j=1,3
1805               do k=1,3
1806                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1807      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1808                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1809               enddo
1810 c              uyder(j,j,1)=uyder(j,j,1)-costh
1811 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1812               uyder(j,j,1)=uyder(j,j,1)
1813      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1814               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1815      &          +uyder(j,j,2)
1816             enddo
1817             do j=1,2
1818               do k=1,3
1819                 do l=1,3
1820                   uygrad(l,k,j,i)=uyder(l,k,j)
1821                   uzgrad(l,k,j,i)=uzder(l,k,j)
1822                 enddo
1823               enddo
1824             enddo
1825             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1826             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1827             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1828             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1829           endif
1830       enddo
1831       do i=1,nres-1
1832         do j=1,2
1833           do k=1,3
1834             do l=1,3
1835               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1836               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1837             enddo
1838           enddo
1839         enddo
1840       enddo
1841       return
1842       end
1843 C-----------------------------------------------------------------------------
1844       subroutine check_vecgrad
1845       implicit real*8 (a-h,o-z)
1846       include 'DIMENSIONS'
1847       include 'sizesclu.dat'
1848       include 'COMMON.IOUNITS'
1849       include 'COMMON.GEO'
1850       include 'COMMON.VAR'
1851       include 'COMMON.LOCAL'
1852       include 'COMMON.CHAIN'
1853       include 'COMMON.VECTORS'
1854       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1855       dimension uyt(3,maxres),uzt(3,maxres)
1856       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1857       double precision delta /1.0d-7/
1858       call vec_and_deriv
1859 cd      do i=1,nres
1860 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1861 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1862 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1863 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1864 cd     &     (dc_norm(if90,i),if90=1,3)
1865 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1866 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1867 cd          write(iout,'(a)')
1868 cd      enddo
1869       do i=1,nres
1870         do j=1,2
1871           do k=1,3
1872             do l=1,3
1873               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1874               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1875             enddo
1876           enddo
1877         enddo
1878       enddo
1879       call vec_and_deriv
1880       do i=1,nres
1881         do j=1,3
1882           uyt(j,i)=uy(j,i)
1883           uzt(j,i)=uz(j,i)
1884         enddo
1885       enddo
1886       do i=1,nres
1887 cd        write (iout,*) 'i=',i
1888         do k=1,3
1889           erij(k)=dc_norm(k,i)
1890         enddo
1891         do j=1,3
1892           do k=1,3
1893             dc_norm(k,i)=erij(k)
1894           enddo
1895           dc_norm(j,i)=dc_norm(j,i)+delta
1896 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1897 c          do k=1,3
1898 c            dc_norm(k,i)=dc_norm(k,i)/fac
1899 c          enddo
1900 c          write (iout,*) (dc_norm(k,i),k=1,3)
1901 c          write (iout,*) (erij(k),k=1,3)
1902           call vec_and_deriv
1903           do k=1,3
1904             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1905             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1906             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1907             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1908           enddo
1909 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1910 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1911 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1912         enddo
1913         do k=1,3
1914           dc_norm(k,i)=erij(k)
1915         enddo
1916 cd        do k=1,3
1917 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1918 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1919 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1920 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1921 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1922 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1923 cd          write (iout,'(a)')
1924 cd        enddo
1925       enddo
1926       return
1927       end
1928 C--------------------------------------------------------------------------
1929       subroutine set_matrices
1930       implicit real*8 (a-h,o-z)
1931       include 'DIMENSIONS'
1932       include 'sizesclu.dat'
1933       include 'COMMON.IOUNITS'
1934       include 'COMMON.GEO'
1935       include 'COMMON.VAR'
1936       include 'COMMON.LOCAL'
1937       include 'COMMON.CHAIN'
1938       include 'COMMON.DERIV'
1939       include 'COMMON.INTERACT'
1940       include 'COMMON.CONTACTS'
1941       include 'COMMON.TORSION'
1942       include 'COMMON.VECTORS'
1943       include 'COMMON.FFIELD'
1944       double precision auxvec(2),auxmat(2,2)
1945 C
1946 C Compute the virtual-bond-torsional-angle dependent quantities needed
1947 C to calculate the el-loc multibody terms of various order.
1948 C
1949       do i=3,nres+1
1950         if (i .lt. nres+1) then
1951           sin1=dsin(phi(i))
1952           cos1=dcos(phi(i))
1953           sintab(i-2)=sin1
1954           costab(i-2)=cos1
1955           obrot(1,i-2)=cos1
1956           obrot(2,i-2)=sin1
1957           sin2=dsin(2*phi(i))
1958           cos2=dcos(2*phi(i))
1959           sintab2(i-2)=sin2
1960           costab2(i-2)=cos2
1961           obrot2(1,i-2)=cos2
1962           obrot2(2,i-2)=sin2
1963           Ug(1,1,i-2)=-cos1
1964           Ug(1,2,i-2)=-sin1
1965           Ug(2,1,i-2)=-sin1
1966           Ug(2,2,i-2)= cos1
1967           Ug2(1,1,i-2)=-cos2
1968           Ug2(1,2,i-2)=-sin2
1969           Ug2(2,1,i-2)=-sin2
1970           Ug2(2,2,i-2)= cos2
1971         else
1972           costab(i-2)=1.0d0
1973           sintab(i-2)=0.0d0
1974           obrot(1,i-2)=1.0d0
1975           obrot(2,i-2)=0.0d0
1976           obrot2(1,i-2)=0.0d0
1977           obrot2(2,i-2)=0.0d0
1978           Ug(1,1,i-2)=1.0d0
1979           Ug(1,2,i-2)=0.0d0
1980           Ug(2,1,i-2)=0.0d0
1981           Ug(2,2,i-2)=1.0d0
1982           Ug2(1,1,i-2)=0.0d0
1983           Ug2(1,2,i-2)=0.0d0
1984           Ug2(2,1,i-2)=0.0d0
1985           Ug2(2,2,i-2)=0.0d0
1986         endif
1987         if (i .gt. 3 .and. i .lt. nres+1) then
1988           obrot_der(1,i-2)=-sin1
1989           obrot_der(2,i-2)= cos1
1990           Ugder(1,1,i-2)= sin1
1991           Ugder(1,2,i-2)=-cos1
1992           Ugder(2,1,i-2)=-cos1
1993           Ugder(2,2,i-2)=-sin1
1994           dwacos2=cos2+cos2
1995           dwasin2=sin2+sin2
1996           obrot2_der(1,i-2)=-dwasin2
1997           obrot2_der(2,i-2)= dwacos2
1998           Ug2der(1,1,i-2)= dwasin2
1999           Ug2der(1,2,i-2)=-dwacos2
2000           Ug2der(2,1,i-2)=-dwacos2
2001           Ug2der(2,2,i-2)=-dwasin2
2002         else
2003           obrot_der(1,i-2)=0.0d0
2004           obrot_der(2,i-2)=0.0d0
2005           Ugder(1,1,i-2)=0.0d0
2006           Ugder(1,2,i-2)=0.0d0
2007           Ugder(2,1,i-2)=0.0d0
2008           Ugder(2,2,i-2)=0.0d0
2009           obrot2_der(1,i-2)=0.0d0
2010           obrot2_der(2,i-2)=0.0d0
2011           Ug2der(1,1,i-2)=0.0d0
2012           Ug2der(1,2,i-2)=0.0d0
2013           Ug2der(2,1,i-2)=0.0d0
2014           Ug2der(2,2,i-2)=0.0d0
2015         endif
2016         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2017           if (itype(i-2).le.ntyp) then
2018             iti = itortyp(itype(i-2))
2019           else
2020             iti=ntortyp+1
2021           endif
2022         else
2023           iti=ntortyp+1
2024         endif
2025         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2026           if (itype(i-1).le.ntyp) then
2027             iti1 = itortyp(itype(i-1))
2028           else
2029             iti1=ntortyp+1
2030           endif
2031         else
2032           iti1=ntortyp+1
2033         endif
2034 cd        write (iout,*) '*******i',i,' iti1',iti
2035 cd        write (iout,*) 'b1',b1(:,iti)
2036 cd        write (iout,*) 'b2',b2(:,iti)
2037 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2038 c        print *,"itilde1 i iti iti1",i,iti,iti1
2039         if (i .gt. iatel_s+2) then
2040           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2041           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2042           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2043           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2044           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2045           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2046           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2047         else
2048           do k=1,2
2049             Ub2(k,i-2)=0.0d0
2050             Ctobr(k,i-2)=0.0d0
2051             Dtobr2(k,i-2)=0.0d0
2052             do l=1,2
2053               EUg(l,k,i-2)=0.0d0
2054               CUg(l,k,i-2)=0.0d0
2055               DUg(l,k,i-2)=0.0d0
2056               DtUg2(l,k,i-2)=0.0d0
2057             enddo
2058           enddo
2059         endif
2060 c        print *,"itilde2 i iti iti1",i,iti,iti1
2061         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2062         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2063         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2064         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2065         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2066         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2067         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2068 c        print *,"itilde3 i iti iti1",i,iti,iti1
2069         do k=1,2
2070           muder(k,i-2)=Ub2der(k,i-2)
2071         enddo
2072         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2073           if (itype(i-1).le.ntyp) then
2074             iti1 = itortyp(itype(i-1))
2075           else
2076             iti1=ntortyp+1
2077           endif
2078         else
2079           iti1=ntortyp+1
2080         endif
2081         do k=1,2
2082           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2083         enddo
2084 C Vectors and matrices dependent on a single virtual-bond dihedral.
2085         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2086         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2087         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2088         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2089         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2090         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2091         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2092         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2093         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2094 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2095 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2096       enddo
2097 C Matrices dependent on two consecutive virtual-bond dihedrals.
2098 C The order of matrices is from left to right.
2099       do i=2,nres-1
2100         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2101         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2102         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2103         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2104         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2105         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2106         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2107         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2108       enddo
2109 cd      do i=1,nres
2110 cd        iti = itortyp(itype(i))
2111 cd        write (iout,*) i
2112 cd        do j=1,2
2113 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2114 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2115 cd        enddo
2116 cd      enddo
2117       return
2118       end
2119 C--------------------------------------------------------------------------
2120       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2121 C
2122 C This subroutine calculates the average interaction energy and its gradient
2123 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2124 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2125 C The potential depends both on the distance of peptide-group centers and on
2126 C the orientation of the CA-CA virtual bonds.
2127 C
2128       implicit real*8 (a-h,o-z)
2129       include 'DIMENSIONS'
2130       include 'sizesclu.dat'
2131       include 'COMMON.CONTROL'
2132       include 'COMMON.IOUNITS'
2133       include 'COMMON.GEO'
2134       include 'COMMON.VAR'
2135       include 'COMMON.LOCAL'
2136       include 'COMMON.CHAIN'
2137       include 'COMMON.DERIV'
2138       include 'COMMON.INTERACT'
2139       include 'COMMON.CONTACTS'
2140       include 'COMMON.TORSION'
2141       include 'COMMON.VECTORS'
2142       include 'COMMON.FFIELD'
2143       include 'COMMON.SHIELD'
2144
2145       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2146      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2147       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2148      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2149       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2150 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2151       double precision scal_el /0.5d0/
2152 C 12/13/98
2153 C 13-go grudnia roku pamietnego...
2154       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2155      &                   0.0d0,1.0d0,0.0d0,
2156      &                   0.0d0,0.0d0,1.0d0/
2157 cd      write(iout,*) 'In EELEC'
2158 cd      do i=1,nloctyp
2159 cd        write(iout,*) 'Type',i
2160 cd        write(iout,*) 'B1',B1(:,i)
2161 cd        write(iout,*) 'B2',B2(:,i)
2162 cd        write(iout,*) 'CC',CC(:,:,i)
2163 cd        write(iout,*) 'DD',DD(:,:,i)
2164 cd        write(iout,*) 'EE',EE(:,:,i)
2165 cd      enddo
2166 cd      call check_vecgrad
2167 cd      stop
2168       if (icheckgrad.eq.1) then
2169         do i=1,nres-1
2170           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2171           do k=1,3
2172             dc_norm(k,i)=dc(k,i)*fac
2173           enddo
2174 c          write (iout,*) 'i',i,' fac',fac
2175         enddo
2176       endif
2177       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2178      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2179      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2180 cd      if (wel_loc.gt.0.0d0) then
2181         if (icheckgrad.eq.1) then
2182         call vec_and_deriv_test
2183         else
2184         call vec_and_deriv
2185         endif
2186         call set_matrices
2187       endif
2188 cd      do i=1,nres-1
2189 cd        write (iout,*) 'i=',i
2190 cd        do k=1,3
2191 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2192 cd        enddo
2193 cd        do k=1,3
2194 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2195 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2196 cd        enddo
2197 cd      enddo
2198       num_conti_hb=0
2199       ees=0.0D0
2200       evdw1=0.0D0
2201       eel_loc=0.0d0
2202       eello_turn3=0.0d0
2203       eello_turn4=0.0d0
2204       ind=0
2205       do i=1,nres
2206         num_cont_hb(i)=0
2207       enddo
2208 cd      print '(a)','Enter EELEC'
2209 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2210       do i=1,nres
2211         gel_loc_loc(i)=0.0d0
2212         gcorr_loc(i)=0.0d0
2213       enddo
2214       do i=iatel_s,iatel_e
2215 C          if (i.eq.1) then
2216            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2217 C     &  .or. itype(i+2).eq.ntyp1) cycle
2218 C          else
2219 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2220 C     &  .or. itype(i+2).eq.ntyp1
2221 C     &  .or. itype(i-1).eq.ntyp1
2222      &) cycle
2223 C         endif
2224         if (itel(i).eq.0) goto 1215
2225         dxi=dc(1,i)
2226         dyi=dc(2,i)
2227         dzi=dc(3,i)
2228         dx_normi=dc_norm(1,i)
2229         dy_normi=dc_norm(2,i)
2230         dz_normi=dc_norm(3,i)
2231         xmedi=c(1,i)+0.5d0*dxi
2232         ymedi=c(2,i)+0.5d0*dyi
2233         zmedi=c(3,i)+0.5d0*dzi
2234           xmedi=mod(xmedi,boxxsize)
2235           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2236           ymedi=mod(ymedi,boxysize)
2237           if (ymedi.lt.0) ymedi=ymedi+boxysize
2238           zmedi=mod(zmedi,boxzsize)
2239           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2240         num_conti=0
2241 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2242         do j=ielstart(i),ielend(i)
2243 C          if (j.le.1) cycle
2244 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2245 C     & .or.itype(j+2).eq.ntyp1
2246 C     &) cycle
2247 C          else
2248           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2249 C     & .or.itype(j+2).eq.ntyp1
2250 C     & .or.itype(j-1).eq.ntyp1
2251      &) cycle
2252 C         endif
2253           if (itel(j).eq.0) goto 1216
2254           ind=ind+1
2255           iteli=itel(i)
2256           itelj=itel(j)
2257           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2258           aaa=app(iteli,itelj)
2259           bbb=bpp(iteli,itelj)
2260 C Diagnostics only!!!
2261 c         aaa=0.0D0
2262 c         bbb=0.0D0
2263 c         ael6i=0.0D0
2264 c         ael3i=0.0D0
2265 C End diagnostics
2266           ael6i=ael6(iteli,itelj)
2267           ael3i=ael3(iteli,itelj)
2268           dxj=dc(1,j)
2269           dyj=dc(2,j)
2270           dzj=dc(3,j)
2271           dx_normj=dc_norm(1,j)
2272           dy_normj=dc_norm(2,j)
2273           dz_normj=dc_norm(3,j)
2274           xj=c(1,j)+0.5D0*dxj
2275           yj=c(2,j)+0.5D0*dyj
2276           zj=c(3,j)+0.5D0*dzj
2277          xj=mod(xj,boxxsize)
2278           if (xj.lt.0) xj=xj+boxxsize
2279           yj=mod(yj,boxysize)
2280           if (yj.lt.0) yj=yj+boxysize
2281           zj=mod(zj,boxzsize)
2282           if (zj.lt.0) zj=zj+boxzsize
2283       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2284       xj_safe=xj
2285       yj_safe=yj
2286       zj_safe=zj
2287       isubchap=0
2288       do xshift=-1,1
2289       do yshift=-1,1
2290       do zshift=-1,1
2291           xj=xj_safe+xshift*boxxsize
2292           yj=yj_safe+yshift*boxysize
2293           zj=zj_safe+zshift*boxzsize
2294           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2295           if(dist_temp.lt.dist_init) then
2296             dist_init=dist_temp
2297             xj_temp=xj
2298             yj_temp=yj
2299             zj_temp=zj
2300             isubchap=1
2301           endif
2302        enddo
2303        enddo
2304        enddo
2305        if (isubchap.eq.1) then
2306           xj=xj_temp-xmedi
2307           yj=yj_temp-ymedi
2308           zj=zj_temp-zmedi
2309        else
2310           xj=xj_safe-xmedi
2311           yj=yj_safe-ymedi
2312           zj=zj_safe-zmedi
2313        endif
2314
2315           rij=xj*xj+yj*yj+zj*zj
2316             sss=sscale(sqrt(rij))
2317             sssgrad=sscagrad(sqrt(rij))
2318           rrmij=1.0D0/rij
2319           rij=dsqrt(rij)
2320           rmij=1.0D0/rij
2321           r3ij=rrmij*rmij
2322           r6ij=r3ij*r3ij
2323           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2324           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2325           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2326           fac=cosa-3.0D0*cosb*cosg
2327           ev1=aaa*r6ij*r6ij
2328 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2329           if (j.eq.i+2) ev1=scal_el*ev1
2330           ev2=bbb*r6ij
2331           fac3=ael6i*r6ij
2332           fac4=ael3i*r3ij
2333           evdwij=ev1+ev2
2334           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2335           el2=fac4*fac
2336           eesij=el1+el2
2337 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2338 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2339           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2340           if (shield_mode.gt.0) then
2341 C          fac_shield(i)=0.4
2342 C          fac_shield(j)=0.6
2343 C#define DEBUG
2344 #ifdef DEBUG
2345           write(iout,*) "ees_compon",i,j,el1,el2,
2346      &    fac_shield(i),fac_shield(j)
2347 #endif
2348 C#undef DEBUG
2349           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2350           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2351           eesij=(el1+el2)
2352      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
2353           ees=ees+eesij
2354           else
2355           fac_shield(i)=1.0
2356           fac_shield(j)=1.0
2357           eesij=(el1+el2)
2358           ees=ees+eesij
2359           endif
2360 C          ees=ees+eesij
2361           evdw1=evdw1+evdwij*sss
2362      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
2363 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2364 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2365 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2366 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2367 C
2368 C Calculate contributions to the Cartesian gradient.
2369 C
2370 #ifdef SPLITELE
2371           facvdw=-6*rrmij*(ev1+evdwij)*sss
2372           facel=-3*rrmij*(el1+eesij)
2373           fac1=fac
2374           erij(1)=xj*rmij
2375           erij(2)=yj*rmij
2376           erij(3)=zj*rmij
2377           if (calc_grad) then
2378 *
2379 * Radial derivatives. First process both termini of the fragment (i,j)
2380 *
2381           ggg(1)=facel*xj
2382           ggg(2)=facel*yj
2383           ggg(3)=facel*zj
2384
2385           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2386      &  (shield_mode.gt.0)) then
2387 C          print *,i,j
2388           do ilist=1,ishield_list(i)
2389            iresshield=shield_list(ilist,i)
2390            do k=1,3
2391            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2392      &      *2.0
2393            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2394      &              rlocshield
2395      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2396             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2397 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2398 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2399 C             if (iresshield.gt.i) then
2400 C               do ishi=i+1,iresshield-1
2401 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2402 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2403 C
2404 C              enddo
2405 C             else
2406 C               do ishi=iresshield,i
2407 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2408 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2409 C
2410 C               enddo
2411 C              endif
2412 C           enddo
2413 C          enddo
2414            enddo
2415           enddo
2416           do ilist=1,ishield_list(j)
2417            iresshield=shield_list(ilist,j)
2418            do k=1,3
2419            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2420      &     *2.0
2421            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2422      &              rlocshield
2423      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2424            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2425            enddo
2426           enddo
2427
2428           do k=1,3
2429             gshieldc(k,i)=gshieldc(k,i)+
2430      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2431             gshieldc(k,j)=gshieldc(k,j)+
2432      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2433             gshieldc(k,i-1)=gshieldc(k,i-1)+
2434      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2435             gshieldc(k,j-1)=gshieldc(k,j-1)+
2436      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2437
2438            enddo
2439            endif
2440
2441           do k=1,3
2442             ghalf=0.5D0*ggg(k)
2443             gelc(k,i)=gelc(k,i)+ghalf
2444             gelc(k,j)=gelc(k,j)+ghalf
2445           enddo
2446 *
2447 * Loop over residues i+1 thru j-1.
2448 *
2449           do k=i+1,j-1
2450             do l=1,3
2451               gelc(l,k)=gelc(l,k)+ggg(l)
2452             enddo
2453           enddo
2454 C          ggg(1)=facvdw*xj
2455 C          ggg(2)=facvdw*yj
2456 C          ggg(3)=facvdw*zj
2457           if (sss.gt.0.0) then
2458           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2459           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2460           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2461           else
2462           ggg(1)=0.0
2463           ggg(2)=0.0
2464           ggg(3)=0.0
2465           endif
2466           do k=1,3
2467             ghalf=0.5D0*ggg(k)
2468             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2469             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2470           enddo
2471 *
2472 * Loop over residues i+1 thru j-1.
2473 *
2474           do k=i+1,j-1
2475             do l=1,3
2476               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2477             enddo
2478           enddo
2479 #else
2480           facvdw=(ev1+evdwij)*sss
2481           facel=el1+eesij
2482           fac1=fac
2483           fac=-3*rrmij*(facvdw+facvdw+facel)
2484           erij(1)=xj*rmij
2485           erij(2)=yj*rmij
2486           erij(3)=zj*rmij
2487           if (calc_grad) then
2488 *
2489 * Radial derivatives. First process both termini of the fragment (i,j)
2490 *
2491           ggg(1)=fac*xj
2492           ggg(2)=fac*yj
2493           ggg(3)=fac*zj
2494           do k=1,3
2495             ghalf=0.5D0*ggg(k)
2496             gelc(k,i)=gelc(k,i)+ghalf
2497             gelc(k,j)=gelc(k,j)+ghalf
2498           enddo
2499 *
2500 * Loop over residues i+1 thru j-1.
2501 *
2502           do k=i+1,j-1
2503             do l=1,3
2504               gelc(l,k)=gelc(l,k)+ggg(l)
2505             enddo
2506           enddo
2507 #endif
2508 *
2509 * Angular part
2510 *
2511           ecosa=2.0D0*fac3*fac1+fac4
2512           fac4=-3.0D0*fac4
2513           fac3=-6.0D0*fac3
2514           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2515           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2516           do k=1,3
2517             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2518             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2519           enddo
2520 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2521 cd   &          (dcosg(k),k=1,3)
2522           do k=1,3
2523             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2524      &      *fac_shield(i)**2*fac_shield(j)**2
2525           enddo
2526           do k=1,3
2527             ghalf=0.5D0*ggg(k)
2528             gelc(k,i)=gelc(k,i)+ghalf
2529      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2530      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2531      &           *fac_shield(i)**2*fac_shield(j)**2
2532
2533             gelc(k,j)=gelc(k,j)+ghalf
2534      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2535      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2536      &           *fac_shield(i)**2*fac_shield(j)**2
2537           enddo
2538           do k=i+1,j-1
2539             do l=1,3
2540               gelc(l,k)=gelc(l,k)+ggg(l)
2541             enddo
2542           enddo
2543           endif
2544
2545           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2546      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2547      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2548 C
2549 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2550 C   energy of a peptide unit is assumed in the form of a second-order
2551 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2552 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2553 C   are computed for EVERY pair of non-contiguous peptide groups.
2554 C
2555           if (j.lt.nres-1) then
2556             j1=j+1
2557             j2=j-1
2558           else
2559             j1=j-1
2560             j2=j-2
2561           endif
2562           kkk=0
2563           do k=1,2
2564             do l=1,2
2565               kkk=kkk+1
2566               muij(kkk)=mu(k,i)*mu(l,j)
2567             enddo
2568           enddo
2569 cd         write (iout,*) 'EELEC: i',i,' j',j
2570 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2571 cd          write(iout,*) 'muij',muij
2572           ury=scalar(uy(1,i),erij)
2573           urz=scalar(uz(1,i),erij)
2574           vry=scalar(uy(1,j),erij)
2575           vrz=scalar(uz(1,j),erij)
2576           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2577           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2578           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2579           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2580 C For diagnostics only
2581 cd          a22=1.0d0
2582 cd          a23=1.0d0
2583 cd          a32=1.0d0
2584 cd          a33=1.0d0
2585           fac=dsqrt(-ael6i)*r3ij
2586 cd          write (2,*) 'fac=',fac
2587 C For diagnostics only
2588 cd          fac=1.0d0
2589           a22=a22*fac
2590           a23=a23*fac
2591           a32=a32*fac
2592           a33=a33*fac
2593 cd          write (iout,'(4i5,4f10.5)')
2594 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2595 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2596 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2597 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2598 cd          write (iout,'(4f10.5)')
2599 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2600 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2601 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2602 cd           write (iout,'(2i3,9f10.5/)') i,j,
2603 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2604           if (calc_grad) then
2605 C Derivatives of the elements of A in virtual-bond vectors
2606           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2607 cd          do k=1,3
2608 cd            do l=1,3
2609 cd              erder(k,l)=0.0d0
2610 cd            enddo
2611 cd          enddo
2612           do k=1,3
2613             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2614             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2615             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2616             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2617             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2618             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2619             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2620             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2621             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2622             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2623             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2624             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2625           enddo
2626 cd          do k=1,3
2627 cd            do l=1,3
2628 cd              uryg(k,l)=0.0d0
2629 cd              urzg(k,l)=0.0d0
2630 cd              vryg(k,l)=0.0d0
2631 cd              vrzg(k,l)=0.0d0
2632 cd            enddo
2633 cd          enddo
2634 C Compute radial contributions to the gradient
2635           facr=-3.0d0*rrmij
2636           a22der=a22*facr
2637           a23der=a23*facr
2638           a32der=a32*facr
2639           a33der=a33*facr
2640 cd          a22der=0.0d0
2641 cd          a23der=0.0d0
2642 cd          a32der=0.0d0
2643 cd          a33der=0.0d0
2644           agg(1,1)=a22der*xj
2645           agg(2,1)=a22der*yj
2646           agg(3,1)=a22der*zj
2647           agg(1,2)=a23der*xj
2648           agg(2,2)=a23der*yj
2649           agg(3,2)=a23der*zj
2650           agg(1,3)=a32der*xj
2651           agg(2,3)=a32der*yj
2652           agg(3,3)=a32der*zj
2653           agg(1,4)=a33der*xj
2654           agg(2,4)=a33der*yj
2655           agg(3,4)=a33der*zj
2656 C Add the contributions coming from er
2657           fac3=-3.0d0*fac
2658           do k=1,3
2659             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2660             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2661             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2662             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2663           enddo
2664           do k=1,3
2665 C Derivatives in DC(i)
2666             ghalf1=0.5d0*agg(k,1)
2667             ghalf2=0.5d0*agg(k,2)
2668             ghalf3=0.5d0*agg(k,3)
2669             ghalf4=0.5d0*agg(k,4)
2670             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2671      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2672             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2673      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2674             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2675      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2676             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2677      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2678 C Derivatives in DC(i+1)
2679             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2680      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2681             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2682      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2683             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2684      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2685             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2686      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2687 C Derivatives in DC(j)
2688             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2689      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2690             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2691      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2692             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2693      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2694             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2695      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2696 C Derivatives in DC(j+1) or DC(nres-1)
2697             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2698      &      -3.0d0*vryg(k,3)*ury)
2699             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2700      &      -3.0d0*vrzg(k,3)*ury)
2701             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2702      &      -3.0d0*vryg(k,3)*urz)
2703             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2704      &      -3.0d0*vrzg(k,3)*urz)
2705 cd            aggi(k,1)=ghalf1
2706 cd            aggi(k,2)=ghalf2
2707 cd            aggi(k,3)=ghalf3
2708 cd            aggi(k,4)=ghalf4
2709 C Derivatives in DC(i+1)
2710 cd            aggi1(k,1)=agg(k,1)
2711 cd            aggi1(k,2)=agg(k,2)
2712 cd            aggi1(k,3)=agg(k,3)
2713 cd            aggi1(k,4)=agg(k,4)
2714 C Derivatives in DC(j)
2715 cd            aggj(k,1)=ghalf1
2716 cd            aggj(k,2)=ghalf2
2717 cd            aggj(k,3)=ghalf3
2718 cd            aggj(k,4)=ghalf4
2719 C Derivatives in DC(j+1)
2720 cd            aggj1(k,1)=0.0d0
2721 cd            aggj1(k,2)=0.0d0
2722 cd            aggj1(k,3)=0.0d0
2723 cd            aggj1(k,4)=0.0d0
2724             if (j.eq.nres-1 .and. i.lt.j-2) then
2725               do l=1,4
2726                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2727 cd                aggj1(k,l)=agg(k,l)
2728               enddo
2729             endif
2730           enddo
2731           endif
2732 c          goto 11111
2733 C Check the loc-el terms by numerical integration
2734           acipa(1,1)=a22
2735           acipa(1,2)=a23
2736           acipa(2,1)=a32
2737           acipa(2,2)=a33
2738           a22=-a22
2739           a23=-a23
2740           do l=1,2
2741             do k=1,3
2742               agg(k,l)=-agg(k,l)
2743               aggi(k,l)=-aggi(k,l)
2744               aggi1(k,l)=-aggi1(k,l)
2745               aggj(k,l)=-aggj(k,l)
2746               aggj1(k,l)=-aggj1(k,l)
2747             enddo
2748           enddo
2749           if (j.lt.nres-1) then
2750             a22=-a22
2751             a32=-a32
2752             do l=1,3,2
2753               do k=1,3
2754                 agg(k,l)=-agg(k,l)
2755                 aggi(k,l)=-aggi(k,l)
2756                 aggi1(k,l)=-aggi1(k,l)
2757                 aggj(k,l)=-aggj(k,l)
2758                 aggj1(k,l)=-aggj1(k,l)
2759               enddo
2760             enddo
2761           else
2762             a22=-a22
2763             a23=-a23
2764             a32=-a32
2765             a33=-a33
2766             do l=1,4
2767               do k=1,3
2768                 agg(k,l)=-agg(k,l)
2769                 aggi(k,l)=-aggi(k,l)
2770                 aggi1(k,l)=-aggi1(k,l)
2771                 aggj(k,l)=-aggj(k,l)
2772                 aggj1(k,l)=-aggj1(k,l)
2773               enddo
2774             enddo
2775           endif
2776           ENDIF ! WCORR
2777 11111     continue
2778           IF (wel_loc.gt.0.0d0) THEN
2779 C Contribution to the local-electrostatic energy coming from the i-j pair
2780           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2781      &     +a33*muij(4)
2782 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2783 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2784           if (shield_mode.eq.0) then
2785            fac_shield(i)=1.0
2786            fac_shield(j)=1.0
2787 C          else
2788 C           fac_shield(i)=0.4
2789 C           fac_shield(j)=0.6
2790           endif
2791           eel_loc_ij=eel_loc_ij
2792      &    *fac_shield(i)*fac_shield(j)
2793      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2794
2795           eel_loc=eel_loc+eel_loc_ij
2796 C Partial derivatives in virtual-bond dihedral angles gamma
2797           if (calc_grad) then
2798           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2799      &  (shield_mode.gt.0)) then
2800 C          print *,i,j
2801
2802           do ilist=1,ishield_list(i)
2803            iresshield=shield_list(ilist,i)
2804            do k=1,3
2805            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2806      &                                          /fac_shield(i)
2807 C     &      *2.0
2808            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2809      &              rlocshield
2810      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2811             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2812      &      +rlocshield
2813            enddo
2814           enddo
2815           do ilist=1,ishield_list(j)
2816            iresshield=shield_list(ilist,j)
2817            do k=1,3
2818            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2819      &                                       /fac_shield(j)
2820 C     &     *2.0
2821            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2822      &              rlocshield
2823      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2824            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2825      &             +rlocshield
2826
2827            enddo
2828           enddo
2829           do k=1,3
2830             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2831      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2832             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2833      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2834             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2835      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2836             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2837      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2838            enddo
2839            endif
2840           if (i.gt.1)
2841      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2842      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2843      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2844      &    *fac_shield(i)*fac_shield(j)
2845           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2846      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2847      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2848      &    *fac_shield(i)*fac_shield(j)
2849
2850 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2851 cd          write(iout,*) 'agg  ',agg
2852 cd          write(iout,*) 'aggi ',aggi
2853 cd          write(iout,*) 'aggi1',aggi1
2854 cd          write(iout,*) 'aggj ',aggj
2855 cd          write(iout,*) 'aggj1',aggj1
2856
2857 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2858           do l=1,3
2859             ggg(l)=(agg(l,1)*muij(1)+
2860      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
2861      &    *fac_shield(i)*fac_shield(j)
2862      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2863
2864           enddo
2865           do k=i+2,j2
2866             do l=1,3
2867               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2868             enddo
2869           enddo
2870 C Remaining derivatives of eello
2871           do l=1,3
2872             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2873      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2874      &    *fac_shield(i)*fac_shield(j)
2875      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2876
2877             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2878      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2879      &    *fac_shield(i)*fac_shield(j)
2880      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2881
2882             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2883      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2884      &    *fac_shield(i)*fac_shield(j)
2885      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2886
2887             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2888      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2889      &    *fac_shield(i)*fac_shield(j)
2890      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2891
2892           enddo
2893           endif
2894           ENDIF
2895           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2896 C Contributions from turns
2897             a_temp(1,1)=a22
2898             a_temp(1,2)=a23
2899             a_temp(2,1)=a32
2900             a_temp(2,2)=a33
2901             call eturn34(i,j,eello_turn3,eello_turn4)
2902           endif
2903 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2904           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2905 C
2906 C Calculate the contact function. The ith column of the array JCONT will
2907 C contain the numbers of atoms that make contacts with the atom I (of numbers
2908 C greater than I). The arrays FACONT and GACONT will contain the values of
2909 C the contact function and its derivative.
2910 c           r0ij=1.02D0*rpp(iteli,itelj)
2911 c           r0ij=1.11D0*rpp(iteli,itelj)
2912             r0ij=2.20D0*rpp(iteli,itelj)
2913 c           r0ij=1.55D0*rpp(iteli,itelj)
2914             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2915             if (fcont.gt.0.0D0) then
2916               num_conti=num_conti+1
2917               if (num_conti.gt.maxconts) then
2918                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2919      &                         ' will skip next contacts for this conf.'
2920               else
2921                 jcont_hb(num_conti,i)=j
2922                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2923      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2924 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2925 C  terms.
2926                 d_cont(num_conti,i)=rij
2927 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2928 C     --- Electrostatic-interaction matrix ---
2929                 a_chuj(1,1,num_conti,i)=a22
2930                 a_chuj(1,2,num_conti,i)=a23
2931                 a_chuj(2,1,num_conti,i)=a32
2932                 a_chuj(2,2,num_conti,i)=a33
2933 C     --- Gradient of rij
2934                 do kkk=1,3
2935                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2936                 enddo
2937 c             if (i.eq.1) then
2938 c                a_chuj(1,1,num_conti,i)=-0.61d0
2939 c                a_chuj(1,2,num_conti,i)= 0.4d0
2940 c                a_chuj(2,1,num_conti,i)= 0.65d0
2941 c                a_chuj(2,2,num_conti,i)= 0.50d0
2942 c             else if (i.eq.2) then
2943 c                a_chuj(1,1,num_conti,i)= 0.0d0
2944 c                a_chuj(1,2,num_conti,i)= 0.0d0
2945 c                a_chuj(2,1,num_conti,i)= 0.0d0
2946 c                a_chuj(2,2,num_conti,i)= 0.0d0
2947 c             endif
2948 C     --- and its gradients
2949 cd                write (iout,*) 'i',i,' j',j
2950 cd                do kkk=1,3
2951 cd                write (iout,*) 'iii 1 kkk',kkk
2952 cd                write (iout,*) agg(kkk,:)
2953 cd                enddo
2954 cd                do kkk=1,3
2955 cd                write (iout,*) 'iii 2 kkk',kkk
2956 cd                write (iout,*) aggi(kkk,:)
2957 cd                enddo
2958 cd                do kkk=1,3
2959 cd                write (iout,*) 'iii 3 kkk',kkk
2960 cd                write (iout,*) aggi1(kkk,:)
2961 cd                enddo
2962 cd                do kkk=1,3
2963 cd                write (iout,*) 'iii 4 kkk',kkk
2964 cd                write (iout,*) aggj(kkk,:)
2965 cd                enddo
2966 cd                do kkk=1,3
2967 cd                write (iout,*) 'iii 5 kkk',kkk
2968 cd                write (iout,*) aggj1(kkk,:)
2969 cd                enddo
2970                 kkll=0
2971                 do k=1,2
2972                   do l=1,2
2973                     kkll=kkll+1
2974                     do m=1,3
2975                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2976                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2977                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2978                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2979                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2980 c                      do mm=1,5
2981 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2982 c                      enddo
2983                     enddo
2984                   enddo
2985                 enddo
2986                 ENDIF
2987                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2988 C Calculate contact energies
2989                 cosa4=4.0D0*cosa
2990                 wij=cosa-3.0D0*cosb*cosg
2991                 cosbg1=cosb+cosg
2992                 cosbg2=cosb-cosg
2993 c               fac3=dsqrt(-ael6i)/r0ij**3
2994                 fac3=dsqrt(-ael6i)*r3ij
2995                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2996                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2997                 if (shield_mode.eq.0) then
2998                 fac_shield(i)=1.0d0
2999                 fac_shield(j)=1.0d0
3000                 else
3001                 ees0plist(num_conti,i)=j
3002 C                fac_shield(i)=0.4d0
3003 C                fac_shield(j)=0.6d0
3004                 endif
3005 c               ees0mij=0.0D0
3006                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3007      &          *fac_shield(i)*fac_shield(j)
3008
3009                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3010      &          *fac_shield(i)*fac_shield(j)
3011
3012 C Diagnostics. Comment out or remove after debugging!
3013 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3014 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3015 c               ees0m(num_conti,i)=0.0D0
3016 C End diagnostics.
3017 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3018 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3019                 facont_hb(num_conti,i)=fcont
3020                 if (calc_grad) then
3021 C Angular derivatives of the contact function
3022                 ees0pij1=fac3/ees0pij
3023                 ees0mij1=fac3/ees0mij
3024                 fac3p=-3.0D0*fac3*rrmij
3025                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3026                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3027 c               ees0mij1=0.0D0
3028                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3029                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3030                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3031                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3032                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3033                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3034                 ecosap=ecosa1+ecosa2
3035                 ecosbp=ecosb1+ecosb2
3036                 ecosgp=ecosg1+ecosg2
3037                 ecosam=ecosa1-ecosa2
3038                 ecosbm=ecosb1-ecosb2
3039                 ecosgm=ecosg1-ecosg2
3040 C Diagnostics
3041 c               ecosap=ecosa1
3042 c               ecosbp=ecosb1
3043 c               ecosgp=ecosg1
3044 c               ecosam=0.0D0
3045 c               ecosbm=0.0D0
3046 c               ecosgm=0.0D0
3047 C End diagnostics
3048                 fprimcont=fprimcont/rij
3049 cd              facont_hb(num_conti,i)=1.0D0
3050 C Following line is for diagnostics.
3051 cd              fprimcont=0.0D0
3052                 do k=1,3
3053                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3054                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3055                 enddo
3056                 do k=1,3
3057                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3058                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3059                 enddo
3060                 gggp(1)=gggp(1)+ees0pijp*xj
3061                 gggp(2)=gggp(2)+ees0pijp*yj
3062                 gggp(3)=gggp(3)+ees0pijp*zj
3063                 gggm(1)=gggm(1)+ees0mijp*xj
3064                 gggm(2)=gggm(2)+ees0mijp*yj
3065                 gggm(3)=gggm(3)+ees0mijp*zj
3066 C Derivatives due to the contact function
3067                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3068                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3069                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3070                 do k=1,3
3071                   ghalfp=0.5D0*gggp(k)
3072                   ghalfm=0.5D0*gggm(k)
3073                   gacontp_hb1(k,num_conti,i)=ghalfp
3074      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3075      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3076      &          *fac_shield(i)*fac_shield(j)
3077
3078                   gacontp_hb2(k,num_conti,i)=ghalfp
3079      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3080      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3081      &          *fac_shield(i)*fac_shield(j)
3082
3083                   gacontp_hb3(k,num_conti,i)=gggp(k)
3084      &          *fac_shield(i)*fac_shield(j)
3085
3086                   gacontm_hb1(k,num_conti,i)=ghalfm
3087      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3088      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3089      &          *fac_shield(i)*fac_shield(j)
3090
3091                   gacontm_hb2(k,num_conti,i)=ghalfm
3092      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3093      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3094      &          *fac_shield(i)*fac_shield(j)
3095
3096                   gacontm_hb3(k,num_conti,i)=gggm(k)
3097      &          *fac_shield(i)*fac_shield(j)
3098
3099                 enddo
3100                 endif
3101 C Diagnostics. Comment out or remove after debugging!
3102 cdiag           do k=1,3
3103 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3104 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3105 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3106 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3107 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3108 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3109 cdiag           enddo
3110               ENDIF ! wcorr
3111               endif  ! num_conti.le.maxconts
3112             endif  ! fcont.gt.0
3113           endif    ! j.gt.i+1
3114  1216     continue
3115         enddo ! j
3116         num_cont_hb(i)=num_conti
3117  1215   continue
3118       enddo   ! i
3119 cd      do i=1,nres
3120 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3121 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3122 cd      enddo
3123 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3124 ccc      eel_loc=eel_loc+eello_turn3
3125       return
3126       end
3127 C-----------------------------------------------------------------------------
3128       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3129 C Third- and fourth-order contributions from turns
3130       implicit real*8 (a-h,o-z)
3131       include 'DIMENSIONS'
3132       include 'sizesclu.dat'
3133       include 'COMMON.IOUNITS'
3134       include 'COMMON.GEO'
3135       include 'COMMON.VAR'
3136       include 'COMMON.LOCAL'
3137       include 'COMMON.CHAIN'
3138       include 'COMMON.DERIV'
3139       include 'COMMON.INTERACT'
3140       include 'COMMON.CONTACTS'
3141       include 'COMMON.TORSION'
3142       include 'COMMON.VECTORS'
3143       include 'COMMON.FFIELD'
3144       include 'COMMON.SHIELD'
3145       include 'COMMON.CONTROL'
3146
3147       dimension ggg(3)
3148       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3149      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3150      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3151       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3152      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3153       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3154       if (j.eq.i+2) then
3155       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3156 C changes suggested by Ana to avoid out of bounds
3157 C     & .or.((i+5).gt.nres)
3158 C     & .or.((i-1).le.0)
3159 C end of changes suggested by Ana
3160      &    .or. itype(i+2).eq.ntyp1
3161      &    .or. itype(i+3).eq.ntyp1
3162 C     &    .or. itype(i+5).eq.ntyp1
3163 C     &    .or. itype(i).eq.ntyp1
3164 C     &    .or. itype(i-1).eq.ntyp1
3165      &    ) goto 179
3166
3167 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3168 C
3169 C               Third-order contributions
3170 C
3171 C                 (i+2)o----(i+3)
3172 C                      | |
3173 C                      | |
3174 C                 (i+1)o----i
3175 C
3176 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3177 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3178         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3179         call transpose2(auxmat(1,1),auxmat1(1,1))
3180         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3181         if (shield_mode.eq.0) then
3182         fac_shield(i)=1.0
3183         fac_shield(j)=1.0
3184 C        else
3185 C        fac_shield(i)=0.4
3186 C        fac_shield(j)=0.6
3187         endif
3188         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3189      &  *fac_shield(i)*fac_shield(j)
3190      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3191
3192         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3193      &  *fac_shield(i)*fac_shield(j)
3194      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3195
3196 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3197 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3198 cd     &    ' eello_turn3_num',4*eello_turn3_num
3199         if (calc_grad) then
3200 C Derivatives in shield mode
3201           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3202      &  (shield_mode.gt.0)) then
3203 C          print *,i,j
3204
3205           do ilist=1,ishield_list(i)
3206            iresshield=shield_list(ilist,i)
3207            do k=1,3
3208            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3209 C     &      *2.0
3210            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3211      &              rlocshield
3212      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3213             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3214      &      +rlocshield
3215            enddo
3216           enddo
3217           do ilist=1,ishield_list(j)
3218            iresshield=shield_list(ilist,j)
3219            do k=1,3
3220            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3221 C     &     *2.0
3222            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3223      &              rlocshield
3224      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3225            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3226      &             +rlocshield
3227
3228            enddo
3229           enddo
3230
3231           do k=1,3
3232             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3233      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3234             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3235      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3236             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3237      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3238             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3239      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3240            enddo
3241            endif
3242
3243 C Derivatives in gamma(i)
3244         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3245         call transpose2(auxmat2(1,1),pizda(1,1))
3246         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3247         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3248      &   *fac_shield(i)*fac_shield(j)
3249
3250 C Derivatives in gamma(i+1)
3251         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3252         call transpose2(auxmat2(1,1),pizda(1,1))
3253         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3254         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3255      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3256      &   *fac_shield(i)*fac_shield(j)
3257
3258 C Cartesian derivatives
3259         do l=1,3
3260           a_temp(1,1)=aggi(l,1)
3261           a_temp(1,2)=aggi(l,2)
3262           a_temp(2,1)=aggi(l,3)
3263           a_temp(2,2)=aggi(l,4)
3264           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3265           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3266      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3267      &   *fac_shield(i)*fac_shield(j)
3268      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3269
3270           a_temp(1,1)=aggi1(l,1)
3271           a_temp(1,2)=aggi1(l,2)
3272           a_temp(2,1)=aggi1(l,3)
3273           a_temp(2,2)=aggi1(l,4)
3274           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3275           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3276      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3277      &   *fac_shield(i)*fac_shield(j)
3278      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3279
3280           a_temp(1,1)=aggj(l,1)
3281           a_temp(1,2)=aggj(l,2)
3282           a_temp(2,1)=aggj(l,3)
3283           a_temp(2,2)=aggj(l,4)
3284           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3285           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3286      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3287      &   *fac_shield(i)*fac_shield(j)
3288      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3289
3290           a_temp(1,1)=aggj1(l,1)
3291           a_temp(1,2)=aggj1(l,2)
3292           a_temp(2,1)=aggj1(l,3)
3293           a_temp(2,2)=aggj1(l,4)
3294           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3295           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3296      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3297      &   *fac_shield(i)*fac_shield(j)
3298      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3299
3300         enddo
3301         endif
3302   179 continue
3303       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3304       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3305 C changes suggested by Ana to avoid out of bounds
3306 C     & .or.((i+5).gt.nres)
3307 C     & .or.((i-1).le.0)
3308 C end of changes suggested by Ana
3309      &    .or. itype(i+3).eq.ntyp1
3310      &    .or. itype(i+4).eq.ntyp1
3311 C     &    .or. itype(i+5).eq.ntyp1
3312      &    .or. itype(i).eq.ntyp1
3313 C     &    .or. itype(i-1).eq.ntyp1
3314      &    ) goto 178
3315
3316 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3317 C
3318 C               Fourth-order contributions
3319 C
3320 C                 (i+3)o----(i+4)
3321 C                     /  |
3322 C               (i+2)o   |
3323 C                     \  |
3324 C                 (i+1)o----i
3325 C
3326 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3327 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3328         iti1=itortyp(itype(i+1))
3329         iti2=itortyp(itype(i+2))
3330         iti3=itortyp(itype(i+3))
3331         call transpose2(EUg(1,1,i+1),e1t(1,1))
3332         call transpose2(Eug(1,1,i+2),e2t(1,1))
3333         call transpose2(Eug(1,1,i+3),e3t(1,1))
3334         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3335         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3336         s1=scalar2(b1(1,iti2),auxvec(1))
3337         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3338         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3339         s2=scalar2(b1(1,iti1),auxvec(1))
3340         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3341         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3342         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3343         if (shield_mode.eq.0) then
3344         fac_shield(i)=1.0
3345         fac_shield(j)=1.0
3346 C        else
3347 C        fac_shield(i)=0.4
3348 C        fac_shield(j)=0.6
3349         endif
3350         eello_turn4=eello_turn4-(s1+s2+s3)
3351      &  *fac_shield(i)*fac_shield(j)
3352      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3353
3354         eello_t4=-(s1+s2+s3)
3355      &  *fac_shield(i)*fac_shield(j)
3356      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3357
3358 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3359 cd     &    ' eello_turn4_num',8*eello_turn4_num
3360 C Derivatives in gamma(i)
3361         if (calc_grad) then
3362           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3363      &  (shield_mode.gt.0)) then
3364 C          print *,i,j
3365
3366           do ilist=1,ishield_list(i)
3367            iresshield=shield_list(ilist,i)
3368            do k=1,3
3369            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3370 C     &      *2.0
3371            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3372      &              rlocshield
3373      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3374             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3375      &      +rlocshield
3376            enddo
3377           enddo
3378           do ilist=1,ishield_list(j)
3379            iresshield=shield_list(ilist,j)
3380            do k=1,3
3381            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3382 C     &     *2.0
3383            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3384      &              rlocshield
3385      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3386            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3387      &             +rlocshield
3388
3389            enddo
3390           enddo
3391
3392           do k=1,3
3393             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3394      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3395             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3396      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3397             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3398      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3399             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3400      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3401            enddo
3402            endif
3403
3404         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3405         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3406         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3407         s1=scalar2(b1(1,iti2),auxvec(1))
3408         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3409         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3410         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3411      &  *fac_shield(i)*fac_shield(j)
3412      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3413
3414 C Derivatives in gamma(i+1)
3415         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3416         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3417         s2=scalar2(b1(1,iti1),auxvec(1))
3418         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3419         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3420         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3421         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3422      &  *fac_shield(i)*fac_shield(j)
3423      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3424
3425 C Derivatives in gamma(i+2)
3426         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3427         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3428         s1=scalar2(b1(1,iti2),auxvec(1))
3429         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3430         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3431         s2=scalar2(b1(1,iti1),auxvec(1))
3432         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3433         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3434         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3435         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3436      &  *fac_shield(i)*fac_shield(j)
3437      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3438
3439 C Cartesian derivatives
3440 C Derivatives of this turn contributions in DC(i+2)
3441         if (j.lt.nres-1) then
3442           do l=1,3
3443             a_temp(1,1)=agg(l,1)
3444             a_temp(1,2)=agg(l,2)
3445             a_temp(2,1)=agg(l,3)
3446             a_temp(2,2)=agg(l,4)
3447             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3448             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3449             s1=scalar2(b1(1,iti2),auxvec(1))
3450             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3451             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3452             s2=scalar2(b1(1,iti1),auxvec(1))
3453             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3454             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3455             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3456             ggg(l)=-(s1+s2+s3)
3457             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3458      &  *fac_shield(i)*fac_shield(j)
3459      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3460
3461           enddo
3462         endif
3463 C Remaining derivatives of this turn contribution
3464         do l=1,3
3465           a_temp(1,1)=aggi(l,1)
3466           a_temp(1,2)=aggi(l,2)
3467           a_temp(2,1)=aggi(l,3)
3468           a_temp(2,2)=aggi(l,4)
3469           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3470           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3471           s1=scalar2(b1(1,iti2),auxvec(1))
3472           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3473           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3474           s2=scalar2(b1(1,iti1),auxvec(1))
3475           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3476           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3477           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3478           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3479      &  *fac_shield(i)*fac_shield(j)
3480      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3481
3482           a_temp(1,1)=aggi1(l,1)
3483           a_temp(1,2)=aggi1(l,2)
3484           a_temp(2,1)=aggi1(l,3)
3485           a_temp(2,2)=aggi1(l,4)
3486           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3487           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3488           s1=scalar2(b1(1,iti2),auxvec(1))
3489           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3490           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3491           s2=scalar2(b1(1,iti1),auxvec(1))
3492           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3493           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3494           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3495           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3496      &  *fac_shield(i)*fac_shield(j)
3497      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3498
3499           a_temp(1,1)=aggj(l,1)
3500           a_temp(1,2)=aggj(l,2)
3501           a_temp(2,1)=aggj(l,3)
3502           a_temp(2,2)=aggj(l,4)
3503           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3504           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3505           s1=scalar2(b1(1,iti2),auxvec(1))
3506           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3507           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3508           s2=scalar2(b1(1,iti1),auxvec(1))
3509           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3510           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3511           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3512           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3513      &  *fac_shield(i)*fac_shield(j)
3514      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3515
3516           a_temp(1,1)=aggj1(l,1)
3517           a_temp(1,2)=aggj1(l,2)
3518           a_temp(2,1)=aggj1(l,3)
3519           a_temp(2,2)=aggj1(l,4)
3520           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3521           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3522           s1=scalar2(b1(1,iti2),auxvec(1))
3523           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3524           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3525           s2=scalar2(b1(1,iti1),auxvec(1))
3526           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3527           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3528           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3529           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3530      &  *fac_shield(i)*fac_shield(j)
3531      &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3532
3533         enddo
3534         endif
3535   178 continue
3536       endif
3537       return
3538       end
3539 C-----------------------------------------------------------------------------
3540       subroutine vecpr(u,v,w)
3541       implicit real*8(a-h,o-z)
3542       dimension u(3),v(3),w(3)
3543       w(1)=u(2)*v(3)-u(3)*v(2)
3544       w(2)=-u(1)*v(3)+u(3)*v(1)
3545       w(3)=u(1)*v(2)-u(2)*v(1)
3546       return
3547       end
3548 C-----------------------------------------------------------------------------
3549       subroutine unormderiv(u,ugrad,unorm,ungrad)
3550 C This subroutine computes the derivatives of a normalized vector u, given
3551 C the derivatives computed without normalization conditions, ugrad. Returns
3552 C ungrad.
3553       implicit none
3554       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3555       double precision vec(3)
3556       double precision scalar
3557       integer i,j
3558 c      write (2,*) 'ugrad',ugrad
3559 c      write (2,*) 'u',u
3560       do i=1,3
3561         vec(i)=scalar(ugrad(1,i),u(1))
3562       enddo
3563 c      write (2,*) 'vec',vec
3564       do i=1,3
3565         do j=1,3
3566           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3567         enddo
3568       enddo
3569 c      write (2,*) 'ungrad',ungrad
3570       return
3571       end
3572 C-----------------------------------------------------------------------------
3573       subroutine escp(evdw2,evdw2_14)
3574 C
3575 C This subroutine calculates the excluded-volume interaction energy between
3576 C peptide-group centers and side chains and its gradient in virtual-bond and
3577 C side-chain vectors.
3578 C
3579       implicit real*8 (a-h,o-z)
3580       include 'DIMENSIONS'
3581       include 'sizesclu.dat'
3582       include 'COMMON.GEO'
3583       include 'COMMON.VAR'
3584       include 'COMMON.LOCAL'
3585       include 'COMMON.CHAIN'
3586       include 'COMMON.DERIV'
3587       include 'COMMON.INTERACT'
3588       include 'COMMON.FFIELD'
3589       include 'COMMON.IOUNITS'
3590       dimension ggg(3)
3591       evdw2=0.0D0
3592       evdw2_14=0.0d0
3593 cd    print '(a)','Enter ESCP'
3594 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3595 c     &  ' scal14',scal14
3596       do i=iatscp_s,iatscp_e
3597         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3598         iteli=itel(i)
3599 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3600 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3601         if (iteli.eq.0) goto 1225
3602         xi=0.5D0*(c(1,i)+c(1,i+1))
3603         yi=0.5D0*(c(2,i)+c(2,i+1))
3604         zi=0.5D0*(c(3,i)+c(3,i+1))
3605 C    Returning the ith atom to box
3606           xi=mod(xi,boxxsize)
3607           if (xi.lt.0) xi=xi+boxxsize
3608           yi=mod(yi,boxysize)
3609           if (yi.lt.0) yi=yi+boxysize
3610           zi=mod(zi,boxzsize)
3611           if (zi.lt.0) zi=zi+boxzsize
3612
3613         do iint=1,nscp_gr(i)
3614
3615         do j=iscpstart(i,iint),iscpend(i,iint)
3616           itypj=iabs(itype(j))
3617           if (itypj.eq.ntyp1) cycle
3618 C Uncomment following three lines for SC-p interactions
3619 c         xj=c(1,nres+j)-xi
3620 c         yj=c(2,nres+j)-yi
3621 c         zj=c(3,nres+j)-zi
3622 C Uncomment following three lines for Ca-p interactions
3623           xj=c(1,j)
3624           yj=c(2,j)
3625           zj=c(3,j)
3626 C returning the jth atom to box
3627           xj=mod(xj,boxxsize)
3628           if (xj.lt.0) xj=xj+boxxsize
3629           yj=mod(yj,boxysize)
3630           if (yj.lt.0) yj=yj+boxysize
3631           zj=mod(zj,boxzsize)
3632           if (zj.lt.0) zj=zj+boxzsize
3633       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3634       xj_safe=xj
3635       yj_safe=yj
3636       zj_safe=zj
3637       subchap=0
3638 C Finding the closest jth atom
3639       do xshift=-1,1
3640       do yshift=-1,1
3641       do zshift=-1,1
3642           xj=xj_safe+xshift*boxxsize
3643           yj=yj_safe+yshift*boxysize
3644           zj=zj_safe+zshift*boxzsize
3645           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3646           if(dist_temp.lt.dist_init) then
3647             dist_init=dist_temp
3648             xj_temp=xj
3649             yj_temp=yj
3650             zj_temp=zj
3651             subchap=1
3652           endif
3653        enddo
3654        enddo
3655        enddo
3656        if (subchap.eq.1) then
3657           xj=xj_temp-xi
3658           yj=yj_temp-yi
3659           zj=zj_temp-zi
3660        else
3661           xj=xj_safe-xi
3662           yj=yj_safe-yi
3663           zj=zj_safe-zi
3664        endif
3665
3666           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3667 C sss is scaling function for smoothing the cutoff gradient otherwise
3668 C the gradient would not be continuouse
3669           sss=sscale(1.0d0/(dsqrt(rrij)))
3670           if (sss.le.0.0d0) cycle
3671           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3672           fac=rrij**expon2
3673           e1=fac*fac*aad(itypj,iteli)
3674           e2=fac*bad(itypj,iteli)
3675           if (iabs(j-i) .le. 2) then
3676             e1=scal14*e1
3677             e2=scal14*e2
3678             evdw2_14=evdw2_14+(e1+e2)*sss
3679           endif
3680           evdwij=e1+e2
3681 c          write (iout,*) i,j,evdwij
3682           evdw2=evdw2+evdwij*sss
3683           if (calc_grad) then
3684 C
3685 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3686 C
3687            fac=-(evdwij+e1)*rrij*sss
3688            fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3689           ggg(1)=xj*fac
3690           ggg(2)=yj*fac
3691           ggg(3)=zj*fac
3692           if (j.lt.i) then
3693 cd          write (iout,*) 'j<i'
3694 C Uncomment following three lines for SC-p interactions
3695 c           do k=1,3
3696 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3697 c           enddo
3698           else
3699 cd          write (iout,*) 'j>i'
3700             do k=1,3
3701               ggg(k)=-ggg(k)
3702 C Uncomment following line for SC-p interactions
3703 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3704             enddo
3705           endif
3706           do k=1,3
3707             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3708           enddo
3709           kstart=min0(i+1,j)
3710           kend=max0(i-1,j-1)
3711 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3712 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3713           do k=kstart,kend
3714             do l=1,3
3715               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3716             enddo
3717           enddo
3718           endif
3719         enddo
3720         enddo ! iint
3721  1225   continue
3722       enddo ! i
3723       do i=1,nct
3724         do j=1,3
3725           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3726           gradx_scp(j,i)=expon*gradx_scp(j,i)
3727         enddo
3728       enddo
3729 C******************************************************************************
3730 C
3731 C                              N O T E !!!
3732 C
3733 C To save time the factor EXPON has been extracted from ALL components
3734 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3735 C use!
3736 C
3737 C******************************************************************************
3738       return
3739       end
3740 C--------------------------------------------------------------------------
3741       subroutine edis(ehpb)
3742 C
3743 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3744 C
3745       implicit real*8 (a-h,o-z)
3746       include 'DIMENSIONS'
3747       include 'sizesclu.dat'
3748       include 'COMMON.SBRIDGE'
3749       include 'COMMON.CHAIN'
3750       include 'COMMON.DERIV'
3751       include 'COMMON.VAR'
3752       include 'COMMON.INTERACT'
3753       include 'COMMON.CONTROL'
3754       dimension ggg(3)
3755       ehpb=0.0D0
3756 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3757 cd    print *,'link_start=',link_start,' link_end=',link_end
3758       if (link_end.eq.0) return
3759       do i=link_start,link_end
3760 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3761 C CA-CA distance used in regularization of structure.
3762         ii=ihpb(i)
3763         jj=jhpb(i)
3764 C iii and jjj point to the residues for which the distance is assigned.
3765         if (ii.gt.nres) then
3766           iii=ii-nres
3767           jjj=jj-nres
3768         else
3769           iii=ii
3770           jjj=jj
3771         endif
3772 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3773 C    distance and angle dependent SS bond potential.
3774 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3775 C     &  iabs(itype(jjj)).eq.1) then
3776 C          call ssbond_ene(iii,jjj,eij)
3777 C          ehpb=ehpb+2*eij
3778 C        else
3779        if (.not.dyn_ss .and. i.le.nss) then
3780          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3781      & iabs(itype(jjj)).eq.1) then
3782           call ssbond_ene(iii,jjj,eij)
3783           ehpb=ehpb+2*eij
3784            endif !ii.gt.neres
3785         else if (ii.gt.nres .and. jj.gt.nres) then
3786 c Restraints from contact prediction
3787           dd=dist(ii,jj)
3788           if (constr_dist.eq.11) then
3789 C            ehpb=ehpb+fordepth(i)**4.0d0
3790 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3791             ehpb=ehpb+fordepth(i)**4.0d0
3792      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3793             fac=fordepth(i)**4.0d0
3794      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3795 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3796 C     &    ehpb,fordepth(i),dd
3797 C             print *,"TUTU"
3798 C            write(iout,*) ehpb,"atu?"
3799 C            ehpb,"tu?"
3800 C            fac=fordepth(i)**4.0d0
3801 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3802            else !constr_dist.eq.11
3803           if (dhpb1(i).gt.0.0d0) then
3804             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3805             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3806 c            write (iout,*) "beta nmr",
3807 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3808           else !dhpb(i).gt.0.00
3809
3810 C Calculate the distance between the two points and its difference from the
3811 C target distance.
3812         dd=dist(ii,jj)
3813         rdis=dd-dhpb(i)
3814 C Get the force constant corresponding to this distance.
3815         waga=forcon(i)
3816 C Calculate the contribution to energy.
3817         ehpb=ehpb+waga*rdis*rdis
3818 C
3819 C Evaluate gradient.
3820 C
3821         fac=waga*rdis/dd
3822         endif !dhpb(i).gt.0
3823         endif
3824 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3825 cd   &   ' waga=',waga,' fac=',fac
3826         do j=1,3
3827           ggg(j)=fac*(c(j,jj)-c(j,ii))
3828         enddo
3829 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3830 C If this is a SC-SC distance, we need to calculate the contributions to the
3831 C Cartesian gradient in the SC vectors (ghpbx).
3832         if (iii.lt.ii) then
3833           do j=1,3
3834             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3835             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3836           enddo
3837         endif
3838         else !ii.gt.nres
3839 C          write(iout,*) "before"
3840           dd=dist(ii,jj)
3841 C          write(iout,*) "after",dd
3842           if (constr_dist.eq.11) then
3843             ehpb=ehpb+fordepth(i)**4.0d0
3844      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3845             fac=fordepth(i)**4.0d0
3846      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3847 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3848 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3849 C            print *,ehpb,"tu?"
3850 C            write(iout,*) ehpb,"btu?",
3851 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3852 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3853 C     &    ehpb,fordepth(i),dd
3854            else
3855           if (dhpb1(i).gt.0.0d0) then
3856             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3857             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3858 c            write (iout,*) "alph nmr",
3859 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3860           else
3861             rdis=dd-dhpb(i)
3862 C Get the force constant corresponding to this distance.
3863             waga=forcon(i)
3864 C Calculate the contribution to energy.
3865             ehpb=ehpb+waga*rdis*rdis
3866 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3867 C
3868 C Evaluate gradient.
3869 C
3870             fac=waga*rdis/dd
3871           endif
3872           endif
3873         do j=1,3
3874           ggg(j)=fac*(c(j,jj)-c(j,ii))
3875         enddo
3876 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3877 C If this is a SC-SC distance, we need to calculate the contributions to the
3878 C Cartesian gradient in the SC vectors (ghpbx).
3879         if (iii.lt.ii) then
3880           do j=1,3
3881             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3882             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3883           enddo
3884         endif
3885         do j=iii,jjj-1
3886           do k=1,3
3887             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3888           enddo
3889         enddo
3890         endif
3891       enddo
3892       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3893       return
3894       end
3895 C--------------------------------------------------------------------------
3896       subroutine ssbond_ene(i,j,eij)
3897 C
3898 C Calculate the distance and angle dependent SS-bond potential energy
3899 C using a free-energy function derived based on RHF/6-31G** ab initio
3900 C calculations of diethyl disulfide.
3901 C
3902 C A. Liwo and U. Kozlowska, 11/24/03
3903 C
3904       implicit real*8 (a-h,o-z)
3905       include 'DIMENSIONS'
3906       include 'sizesclu.dat'
3907       include 'COMMON.SBRIDGE'
3908       include 'COMMON.CHAIN'
3909       include 'COMMON.DERIV'
3910       include 'COMMON.LOCAL'
3911       include 'COMMON.INTERACT'
3912       include 'COMMON.VAR'
3913       include 'COMMON.IOUNITS'
3914       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3915       itypi=iabs(itype(i))
3916       xi=c(1,nres+i)
3917       yi=c(2,nres+i)
3918       zi=c(3,nres+i)
3919       dxi=dc_norm(1,nres+i)
3920       dyi=dc_norm(2,nres+i)
3921       dzi=dc_norm(3,nres+i)
3922       dsci_inv=dsc_inv(itypi)
3923       itypj=iabs(itype(j))
3924       dscj_inv=dsc_inv(itypj)
3925       xj=c(1,nres+j)-xi
3926       yj=c(2,nres+j)-yi
3927       zj=c(3,nres+j)-zi
3928       dxj=dc_norm(1,nres+j)
3929       dyj=dc_norm(2,nres+j)
3930       dzj=dc_norm(3,nres+j)
3931       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3932       rij=dsqrt(rrij)
3933       erij(1)=xj*rij
3934       erij(2)=yj*rij
3935       erij(3)=zj*rij
3936       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3937       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3938       om12=dxi*dxj+dyi*dyj+dzi*dzj
3939       do k=1,3
3940         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3941         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3942       enddo
3943       rij=1.0d0/rij
3944       deltad=rij-d0cm
3945       deltat1=1.0d0-om1
3946       deltat2=1.0d0+om2
3947       deltat12=om2-om1+2.0d0
3948       cosphi=om12-om1*om2
3949       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3950      &  +akct*deltad*deltat12
3951      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3952 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3953 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3954 c     &  " deltat12",deltat12," eij",eij
3955       ed=2*akcm*deltad+akct*deltat12
3956       pom1=akct*deltad
3957       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3958       eom1=-2*akth*deltat1-pom1-om2*pom2
3959       eom2= 2*akth*deltat2+pom1-om1*pom2
3960       eom12=pom2
3961       do k=1,3
3962         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3963       enddo
3964       do k=1,3
3965         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3966      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3967         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3968      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3969       enddo
3970 C
3971 C Calculate the components of the gradient in DC and X
3972 C
3973       do k=i,j-1
3974         do l=1,3
3975           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3976         enddo
3977       enddo
3978       return
3979       end
3980 C--------------------------------------------------------------------------
3981       subroutine ebond(estr)
3982 c
3983 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3984 c
3985       implicit real*8 (a-h,o-z)
3986       include 'DIMENSIONS'
3987       include 'sizesclu.dat'
3988       include 'COMMON.LOCAL'
3989       include 'COMMON.GEO'
3990       include 'COMMON.INTERACT'
3991       include 'COMMON.DERIV'
3992       include 'COMMON.VAR'
3993       include 'COMMON.CHAIN'
3994       include 'COMMON.IOUNITS'
3995       include 'COMMON.NAMES'
3996       include 'COMMON.FFIELD'
3997       include 'COMMON.CONTROL'
3998       logical energy_dec /.false./
3999       double precision u(3),ud(3)
4000       estr=0.0d0
4001       estr1=0.0d0
4002       do i=nnt+1,nct
4003         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4004 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4005 C          do j=1,3
4006 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4007 C     &      *dc(j,i-1)/vbld(i)
4008 C          enddo
4009 C          if (energy_dec) write(iout,*)
4010 C     &       "estr1",i,vbld(i),distchainmax,
4011 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4012 C        else
4013          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4014         diff = vbld(i)-vbldpDUM
4015          else
4016           diff = vbld(i)-vbldp0
4017 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4018          endif
4019           estr=estr+diff*diff
4020           do j=1,3
4021             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4022           enddo
4023 C        endif
4024 C        write (iout,'(a7,i5,4f7.3)')
4025 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4026       enddo
4027       estr=0.5d0*AKP*estr+estr1
4028 c
4029 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4030 c
4031       do i=nnt,nct
4032         iti=iabs(itype(i))
4033         if (iti.ne.10 .and. iti.ne.ntyp1) then
4034           nbi=nbondterm(iti)
4035           if (nbi.eq.1) then
4036             diff=vbld(i+nres)-vbldsc0(1,iti)
4037 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4038 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4039             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4040             do j=1,3
4041               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4042             enddo
4043           else
4044             do j=1,nbi
4045               diff=vbld(i+nres)-vbldsc0(j,iti)
4046               ud(j)=aksc(j,iti)*diff
4047               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4048             enddo
4049             uprod=u(1)
4050             do j=2,nbi
4051               uprod=uprod*u(j)
4052             enddo
4053             usum=0.0d0
4054             usumsqder=0.0d0
4055             do j=1,nbi
4056               uprod1=1.0d0
4057               uprod2=1.0d0
4058               do k=1,nbi
4059                 if (k.ne.j) then
4060                   uprod1=uprod1*u(k)
4061                   uprod2=uprod2*u(k)*u(k)
4062                 endif
4063               enddo
4064               usum=usum+uprod1
4065               usumsqder=usumsqder+ud(j)*uprod2
4066             enddo
4067 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4068 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4069             estr=estr+uprod/usum
4070             do j=1,3
4071              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4072             enddo
4073           endif
4074         endif
4075       enddo
4076       return
4077       end
4078 #ifdef CRYST_THETA
4079 C--------------------------------------------------------------------------
4080       subroutine ebend(etheta,ethetacnstr)
4081 C
4082 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4083 C angles gamma and its derivatives in consecutive thetas and gammas.
4084 C
4085       implicit real*8 (a-h,o-z)
4086       include 'DIMENSIONS'
4087       include 'sizesclu.dat'
4088       include 'COMMON.LOCAL'
4089       include 'COMMON.GEO'
4090       include 'COMMON.INTERACT'
4091       include 'COMMON.DERIV'
4092       include 'COMMON.VAR'
4093       include 'COMMON.CHAIN'
4094       include 'COMMON.IOUNITS'
4095       include 'COMMON.NAMES'
4096       include 'COMMON.FFIELD'
4097       include 'COMMON.TORCNSTR'
4098       common /calcthet/ term1,term2,termm,diffak,ratak,
4099      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4100      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4101       double precision y(2),z(2)
4102       delta=0.02d0*pi
4103 c      time11=dexp(-2*time)
4104 c      time12=1.0d0
4105       etheta=0.0D0
4106 c      write (iout,*) "nres",nres
4107 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4108 c      write (iout,*) ithet_start,ithet_end
4109       do i=ithet_start,ithet_end
4110         if (i.le.2) cycle
4111         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4112      &  .or.itype(i).eq.ntyp1) cycle
4113 C Zero the energy function and its derivative at 0 or pi.
4114         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4115         it=itype(i-1)
4116         ichir1=isign(1,itype(i-2))
4117         ichir2=isign(1,itype(i))
4118          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4119          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4120          if (itype(i-1).eq.10) then
4121           itype1=isign(10,itype(i-2))
4122           ichir11=isign(1,itype(i-2))
4123           ichir12=isign(1,itype(i-2))
4124           itype2=isign(10,itype(i))
4125           ichir21=isign(1,itype(i))
4126           ichir22=isign(1,itype(i))
4127          endif
4128          if (i.eq.3) then
4129           y(1)=0.0D0
4130           y(2)=0.0D0
4131           else
4132         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4133 #ifdef OSF
4134           phii=phi(i)
4135 c          icrc=0
4136 c          call proc_proc(phii,icrc)
4137           if (icrc.eq.1) phii=150.0
4138 #else
4139           phii=phi(i)
4140 #endif
4141           y(1)=dcos(phii)
4142           y(2)=dsin(phii)
4143         else
4144           y(1)=0.0D0
4145           y(2)=0.0D0
4146         endif
4147         endif
4148         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4149 #ifdef OSF
4150           phii1=phi(i+1)
4151 c          icrc=0
4152 c          call proc_proc(phii1,icrc)
4153           if (icrc.eq.1) phii1=150.0
4154           phii1=pinorm(phii1)
4155           z(1)=cos(phii1)
4156 #else
4157           phii1=phi(i+1)
4158           z(1)=dcos(phii1)
4159 #endif
4160           z(2)=dsin(phii1)
4161         else
4162           z(1)=0.0D0
4163           z(2)=0.0D0
4164         endif
4165 C Calculate the "mean" value of theta from the part of the distribution
4166 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4167 C In following comments this theta will be referred to as t_c.
4168         thet_pred_mean=0.0d0
4169         do k=1,2
4170             athetk=athet(k,it,ichir1,ichir2)
4171             bthetk=bthet(k,it,ichir1,ichir2)
4172           if (it.eq.10) then
4173              athetk=athet(k,itype1,ichir11,ichir12)
4174              bthetk=bthet(k,itype2,ichir21,ichir22)
4175           endif
4176           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4177         enddo
4178 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4179         dthett=thet_pred_mean*ssd
4180         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4181 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4182 C Derivatives of the "mean" values in gamma1 and gamma2.
4183         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4184      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4185          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4186      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4187          if (it.eq.10) then
4188       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4189      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4190         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4191      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4192          endif
4193         if (theta(i).gt.pi-delta) then
4194           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4195      &         E_tc0)
4196           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4197           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4198           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4199      &        E_theta)
4200           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4201      &        E_tc)
4202         else if (theta(i).lt.delta) then
4203           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4204           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4205           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4206      &        E_theta)
4207           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4208           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4209      &        E_tc)
4210         else
4211           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4212      &        E_theta,E_tc)
4213         endif
4214         etheta=etheta+ethetai
4215 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4216 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4217         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4218         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4219         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4220 c 1215   continue
4221       enddo
4222 C Ufff.... We've done all this!!!
4223 C now constrains
4224       ethetacnstr=0.0d0
4225 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4226       do i=1,ntheta_constr
4227         itheta=itheta_constr(i)
4228         thetiii=theta(itheta)
4229         difi=pinorm(thetiii-theta_constr0(i))
4230         if (difi.gt.theta_drange(i)) then
4231           difi=difi-theta_drange(i)
4232           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4233           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4234      &    +for_thet_constr(i)*difi**3
4235         else if (difi.lt.-drange(i)) then
4236           difi=difi+drange(i)
4237           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4238           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4239      &    +for_thet_constr(i)*difi**3
4240         else
4241           difi=0.0
4242         endif
4243 C       if (energy_dec) then
4244 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4245 C     &    i,itheta,rad2deg*thetiii,
4246 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4247 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4248 C     &    gloc(itheta+nphi-2,icg)
4249 C        endif
4250       enddo
4251       return
4252       end
4253 C---------------------------------------------------------------------------
4254       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4255      &     E_tc)
4256       implicit real*8 (a-h,o-z)
4257       include 'DIMENSIONS'
4258       include 'COMMON.LOCAL'
4259       include 'COMMON.IOUNITS'
4260       common /calcthet/ term1,term2,termm,diffak,ratak,
4261      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4262      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4263 C Calculate the contributions to both Gaussian lobes.
4264 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4265 C The "polynomial part" of the "standard deviation" of this part of
4266 C the distribution.
4267         sig=polthet(3,it)
4268         do j=2,0,-1
4269           sig=sig*thet_pred_mean+polthet(j,it)
4270         enddo
4271 C Derivative of the "interior part" of the "standard deviation of the"
4272 C gamma-dependent Gaussian lobe in t_c.
4273         sigtc=3*polthet(3,it)
4274         do j=2,1,-1
4275           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4276         enddo
4277         sigtc=sig*sigtc
4278 C Set the parameters of both Gaussian lobes of the distribution.
4279 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4280         fac=sig*sig+sigc0(it)
4281         sigcsq=fac+fac
4282         sigc=1.0D0/sigcsq
4283 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4284         sigsqtc=-4.0D0*sigcsq*sigtc
4285 c       print *,i,sig,sigtc,sigsqtc
4286 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4287         sigtc=-sigtc/(fac*fac)
4288 C Following variable is sigma(t_c)**(-2)
4289         sigcsq=sigcsq*sigcsq
4290         sig0i=sig0(it)
4291         sig0inv=1.0D0/sig0i**2
4292         delthec=thetai-thet_pred_mean
4293         delthe0=thetai-theta0i
4294         term1=-0.5D0*sigcsq*delthec*delthec
4295         term2=-0.5D0*sig0inv*delthe0*delthe0
4296 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4297 C NaNs in taking the logarithm. We extract the largest exponent which is added
4298 C to the energy (this being the log of the distribution) at the end of energy
4299 C term evaluation for this virtual-bond angle.
4300         if (term1.gt.term2) then
4301           termm=term1
4302           term2=dexp(term2-termm)
4303           term1=1.0d0
4304         else
4305           termm=term2
4306           term1=dexp(term1-termm)
4307           term2=1.0d0
4308         endif
4309 C The ratio between the gamma-independent and gamma-dependent lobes of
4310 C the distribution is a Gaussian function of thet_pred_mean too.
4311         diffak=gthet(2,it)-thet_pred_mean
4312         ratak=diffak/gthet(3,it)**2
4313         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4314 C Let's differentiate it in thet_pred_mean NOW.
4315         aktc=ak*ratak
4316 C Now put together the distribution terms to make complete distribution.
4317         termexp=term1+ak*term2
4318         termpre=sigc+ak*sig0i
4319 C Contribution of the bending energy from this theta is just the -log of
4320 C the sum of the contributions from the two lobes and the pre-exponential
4321 C factor. Simple enough, isn't it?
4322         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4323 C NOW the derivatives!!!
4324 C 6/6/97 Take into account the deformation.
4325         E_theta=(delthec*sigcsq*term1
4326      &       +ak*delthe0*sig0inv*term2)/termexp
4327         E_tc=((sigtc+aktc*sig0i)/termpre
4328      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4329      &       aktc*term2)/termexp)
4330       return
4331       end
4332 c-----------------------------------------------------------------------------
4333       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4334       implicit real*8 (a-h,o-z)
4335       include 'DIMENSIONS'
4336       include 'COMMON.LOCAL'
4337       include 'COMMON.IOUNITS'
4338       common /calcthet/ term1,term2,termm,diffak,ratak,
4339      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4340      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4341       delthec=thetai-thet_pred_mean
4342       delthe0=thetai-theta0i
4343 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4344       t3 = thetai-thet_pred_mean
4345       t6 = t3**2
4346       t9 = term1
4347       t12 = t3*sigcsq
4348       t14 = t12+t6*sigsqtc
4349       t16 = 1.0d0
4350       t21 = thetai-theta0i
4351       t23 = t21**2
4352       t26 = term2
4353       t27 = t21*t26
4354       t32 = termexp
4355       t40 = t32**2
4356       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4357      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4358      & *(-t12*t9-ak*sig0inv*t27)
4359       return
4360       end
4361 #else
4362 C--------------------------------------------------------------------------
4363       subroutine ebend(etheta,ethetacnstr)
4364 C
4365 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4366 C angles gamma and its derivatives in consecutive thetas and gammas.
4367 C ab initio-derived potentials from
4368 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4369 C
4370       implicit real*8 (a-h,o-z)
4371       include 'DIMENSIONS'
4372       include 'sizesclu.dat'
4373       include 'COMMON.LOCAL'
4374       include 'COMMON.GEO'
4375       include 'COMMON.INTERACT'
4376       include 'COMMON.DERIV'
4377       include 'COMMON.VAR'
4378       include 'COMMON.CHAIN'
4379       include 'COMMON.IOUNITS'
4380       include 'COMMON.NAMES'
4381       include 'COMMON.FFIELD'
4382       include 'COMMON.CONTROL'
4383       include 'COMMON.TORCNSTR'
4384       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4385      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4386      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4387      & sinph1ph2(maxdouble,maxdouble)
4388       logical lprn /.false./, lprn1 /.false./
4389       etheta=0.0D0
4390 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4391       do i=ithet_start,ithet_end
4392         if (i.le.2) cycle
4393         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4394      &  .or.itype(i).eq.ntyp1) cycle
4395 c        if (itype(i-1).eq.ntyp1) cycle
4396         if (iabs(itype(i+1)).eq.20) iblock=2
4397         if (iabs(itype(i+1)).ne.20) iblock=1
4398         dethetai=0.0d0
4399         dephii=0.0d0
4400         dephii1=0.0d0
4401         theti2=0.5d0*theta(i)
4402         ityp2=ithetyp((itype(i-1)))
4403         do k=1,nntheterm
4404           coskt(k)=dcos(k*theti2)
4405           sinkt(k)=dsin(k*theti2)
4406         enddo
4407         if (i.eq.3) then
4408           phii=0.0d0
4409           ityp1=nthetyp+1
4410           do k=1,nsingle
4411             cosph1(k)=0.0d0
4412             sinph1(k)=0.0d0
4413           enddo
4414         else
4415         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4416 #ifdef OSF
4417           phii=phi(i)
4418           if (phii.ne.phii) phii=150.0
4419 #else
4420           phii=phi(i)
4421 #endif
4422           ityp1=ithetyp((itype(i-2)))
4423           do k=1,nsingle
4424             cosph1(k)=dcos(k*phii)
4425             sinph1(k)=dsin(k*phii)
4426           enddo
4427         else
4428           phii=0.0d0
4429 c          ityp1=nthetyp+1
4430           do k=1,nsingle
4431             ityp1=ithetyp((itype(i-2)))
4432             cosph1(k)=0.0d0
4433             sinph1(k)=0.0d0
4434           enddo
4435         endif
4436         endif
4437         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4438 #ifdef OSF
4439           phii1=phi(i+1)
4440           if (phii1.ne.phii1) phii1=150.0
4441           phii1=pinorm(phii1)
4442 #else
4443           phii1=phi(i+1)
4444 #endif
4445           ityp3=ithetyp((itype(i)))
4446           do k=1,nsingle
4447             cosph2(k)=dcos(k*phii1)
4448             sinph2(k)=dsin(k*phii1)
4449           enddo
4450         else
4451           phii1=0.0d0
4452 c          ityp3=nthetyp+1
4453           ityp3=ithetyp((itype(i)))
4454           do k=1,nsingle
4455             cosph2(k)=0.0d0
4456             sinph2(k)=0.0d0
4457           enddo
4458         endif
4459 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4460 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4461 c        call flush(iout)
4462         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4463         do k=1,ndouble
4464           do l=1,k-1
4465             ccl=cosph1(l)*cosph2(k-l)
4466             ssl=sinph1(l)*sinph2(k-l)
4467             scl=sinph1(l)*cosph2(k-l)
4468             csl=cosph1(l)*sinph2(k-l)
4469             cosph1ph2(l,k)=ccl-ssl
4470             cosph1ph2(k,l)=ccl+ssl
4471             sinph1ph2(l,k)=scl+csl
4472             sinph1ph2(k,l)=scl-csl
4473           enddo
4474         enddo
4475         if (lprn) then
4476         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4477      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4478         write (iout,*) "coskt and sinkt"
4479         do k=1,nntheterm
4480           write (iout,*) k,coskt(k),sinkt(k)
4481         enddo
4482         endif
4483         do k=1,ntheterm
4484           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4485           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4486      &      *coskt(k)
4487           if (lprn)
4488      &    write (iout,*) "k",k," aathet",
4489      &    aathet(k,ityp1,ityp2,ityp3,iblock),
4490      &     " ethetai",ethetai
4491         enddo
4492         if (lprn) then
4493         write (iout,*) "cosph and sinph"
4494         do k=1,nsingle
4495           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4496         enddo
4497         write (iout,*) "cosph1ph2 and sinph2ph2"
4498         do k=2,ndouble
4499           do l=1,k-1
4500             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4501      &         sinph1ph2(l,k),sinph1ph2(k,l)
4502           enddo
4503         enddo
4504         write(iout,*) "ethetai",ethetai
4505         endif
4506         do m=1,ntheterm2
4507           do k=1,nsingle
4508             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4509      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4510      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4511      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4512             ethetai=ethetai+sinkt(m)*aux
4513             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4514             dephii=dephii+k*sinkt(m)*(
4515      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4516      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4517             dephii1=dephii1+k*sinkt(m)*(
4518      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4519      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4520             if (lprn)
4521      &      write (iout,*) "m",m," k",k," bbthet",
4522      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4523      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4524      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4525      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4526           enddo
4527         enddo
4528         if (lprn)
4529      &  write(iout,*) "ethetai",ethetai
4530         do m=1,ntheterm3
4531           do k=2,ndouble
4532             do l=1,k-1
4533               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4534      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4535      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4536      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4537               ethetai=ethetai+sinkt(m)*aux
4538               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4539               dephii=dephii+l*sinkt(m)*(
4540      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4541      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4542      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4543      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4544               dephii1=dephii1+(k-l)*sinkt(m)*(
4545      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4546      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4547      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4548      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4549               if (lprn) then
4550               write (iout,*) "m",m," k",k," l",l," ffthet",
4551      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4552      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4553      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4554      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4555      &            " ethetai",ethetai
4556               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4557      &            cosph1ph2(k,l)*sinkt(m),
4558      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4559               endif
4560             enddo
4561           enddo
4562         enddo
4563 10      continue
4564         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4565      &   i,theta(i)*rad2deg,phii*rad2deg,
4566      &   phii1*rad2deg,ethetai
4567         etheta=etheta+ethetai
4568         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4569         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4570 c        gloc(nphi+i-2,icg)=wang*dethetai
4571         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4572       enddo
4573 C now constrains
4574       ethetacnstr=0.0d0
4575 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4576       do i=1,ntheta_constr
4577         itheta=itheta_constr(i)
4578         thetiii=theta(itheta)
4579         difi=pinorm(thetiii-theta_constr0(i))
4580         if (difi.gt.theta_drange(i)) then
4581           difi=difi-theta_drange(i)
4582           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4583           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4584      &    +for_thet_constr(i)*difi**3
4585         else if (difi.lt.-drange(i)) then
4586           difi=difi+drange(i)
4587           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4588           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4589      &    +for_thet_constr(i)*difi**3
4590         else
4591           difi=0.0
4592         endif
4593 C       if (energy_dec) then
4594 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4595 C     &    i,itheta,rad2deg*thetiii,
4596 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4597 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4598 C     &    gloc(itheta+nphi-2,icg)
4599 C        endif
4600       enddo
4601       return
4602       end
4603 #endif
4604 #ifdef CRYST_SC
4605 c-----------------------------------------------------------------------------
4606       subroutine esc(escloc)
4607 C Calculate the local energy of a side chain and its derivatives in the
4608 C corresponding virtual-bond valence angles THETA and the spherical angles
4609 C ALPHA and OMEGA.
4610       implicit real*8 (a-h,o-z)
4611       include 'DIMENSIONS'
4612       include 'sizesclu.dat'
4613       include 'COMMON.GEO'
4614       include 'COMMON.LOCAL'
4615       include 'COMMON.VAR'
4616       include 'COMMON.INTERACT'
4617       include 'COMMON.DERIV'
4618       include 'COMMON.CHAIN'
4619       include 'COMMON.IOUNITS'
4620       include 'COMMON.NAMES'
4621       include 'COMMON.FFIELD'
4622       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4623      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4624       common /sccalc/ time11,time12,time112,theti,it,nlobit
4625       delta=0.02d0*pi
4626       escloc=0.0D0
4627 c     write (iout,'(a)') 'ESC'
4628       do i=loc_start,loc_end
4629         it=itype(i)
4630         if (it.eq.ntyp1) cycle
4631         if (it.eq.10) goto 1
4632         nlobit=nlob(iabs(it))
4633 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4634 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4635         theti=theta(i+1)-pipol
4636         x(1)=dtan(theti)
4637         x(2)=alph(i)
4638         x(3)=omeg(i)
4639 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4640
4641         if (x(2).gt.pi-delta) then
4642           xtemp(1)=x(1)
4643           xtemp(2)=pi-delta
4644           xtemp(3)=x(3)
4645           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4646           xtemp(2)=pi
4647           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4648           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4649      &        escloci,dersc(2))
4650           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4651      &        ddersc0(1),dersc(1))
4652           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4653      &        ddersc0(3),dersc(3))
4654           xtemp(2)=pi-delta
4655           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4656           xtemp(2)=pi
4657           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4658           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4659      &            dersc0(2),esclocbi,dersc02)
4660           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4661      &            dersc12,dersc01)
4662           call splinthet(x(2),0.5d0*delta,ss,ssd)
4663           dersc0(1)=dersc01
4664           dersc0(2)=dersc02
4665           dersc0(3)=0.0d0
4666           do k=1,3
4667             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4668           enddo
4669           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4670 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4671 c    &             esclocbi,ss,ssd
4672           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4673 c         escloci=esclocbi
4674 c         write (iout,*) escloci
4675         else if (x(2).lt.delta) then
4676           xtemp(1)=x(1)
4677           xtemp(2)=delta
4678           xtemp(3)=x(3)
4679           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4680           xtemp(2)=0.0d0
4681           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4682           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4683      &        escloci,dersc(2))
4684           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4685      &        ddersc0(1),dersc(1))
4686           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4687      &        ddersc0(3),dersc(3))
4688           xtemp(2)=delta
4689           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4690           xtemp(2)=0.0d0
4691           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4692           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4693      &            dersc0(2),esclocbi,dersc02)
4694           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4695      &            dersc12,dersc01)
4696           dersc0(1)=dersc01
4697           dersc0(2)=dersc02
4698           dersc0(3)=0.0d0
4699           call splinthet(x(2),0.5d0*delta,ss,ssd)
4700           do k=1,3
4701             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4702           enddo
4703           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4704 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4705 c    &             esclocbi,ss,ssd
4706           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4707 c         write (iout,*) escloci
4708         else
4709           call enesc(x,escloci,dersc,ddummy,.false.)
4710         endif
4711
4712         escloc=escloc+escloci
4713 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4714
4715         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4716      &   wscloc*dersc(1)
4717         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4718         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4719     1   continue
4720       enddo
4721       return
4722       end
4723 C---------------------------------------------------------------------------
4724       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4725       implicit real*8 (a-h,o-z)
4726       include 'DIMENSIONS'
4727       include 'COMMON.GEO'
4728       include 'COMMON.LOCAL'
4729       include 'COMMON.IOUNITS'
4730       common /sccalc/ time11,time12,time112,theti,it,nlobit
4731       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4732       double precision contr(maxlob,-1:1)
4733       logical mixed
4734 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4735         escloc_i=0.0D0
4736         do j=1,3
4737           dersc(j)=0.0D0
4738           if (mixed) ddersc(j)=0.0d0
4739         enddo
4740         x3=x(3)
4741
4742 C Because of periodicity of the dependence of the SC energy in omega we have
4743 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4744 C To avoid underflows, first compute & store the exponents.
4745
4746         do iii=-1,1
4747
4748           x(3)=x3+iii*dwapi
4749
4750           do j=1,nlobit
4751             do k=1,3
4752               z(k)=x(k)-censc(k,j,it)
4753             enddo
4754             do k=1,3
4755               Axk=0.0D0
4756               do l=1,3
4757                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4758               enddo
4759               Ax(k,j,iii)=Axk
4760             enddo
4761             expfac=0.0D0
4762             do k=1,3
4763               expfac=expfac+Ax(k,j,iii)*z(k)
4764             enddo
4765             contr(j,iii)=expfac
4766           enddo ! j
4767
4768         enddo ! iii
4769
4770         x(3)=x3
4771 C As in the case of ebend, we want to avoid underflows in exponentiation and
4772 C subsequent NaNs and INFs in energy calculation.
4773 C Find the largest exponent
4774         emin=contr(1,-1)
4775         do iii=-1,1
4776           do j=1,nlobit
4777             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4778           enddo
4779         enddo
4780         emin=0.5D0*emin
4781 cd      print *,'it=',it,' emin=',emin
4782
4783 C Compute the contribution to SC energy and derivatives
4784         do iii=-1,1
4785
4786           do j=1,nlobit
4787             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4788 cd          print *,'j=',j,' expfac=',expfac
4789             escloc_i=escloc_i+expfac
4790             do k=1,3
4791               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4792             enddo
4793             if (mixed) then
4794               do k=1,3,2
4795                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4796      &            +gaussc(k,2,j,it))*expfac
4797               enddo
4798             endif
4799           enddo
4800
4801         enddo ! iii
4802
4803         dersc(1)=dersc(1)/cos(theti)**2
4804         ddersc(1)=ddersc(1)/cos(theti)**2
4805         ddersc(3)=ddersc(3)
4806
4807         escloci=-(dlog(escloc_i)-emin)
4808         do j=1,3
4809           dersc(j)=dersc(j)/escloc_i
4810         enddo
4811         if (mixed) then
4812           do j=1,3,2
4813             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4814           enddo
4815         endif
4816       return
4817       end
4818 C------------------------------------------------------------------------------
4819       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4820       implicit real*8 (a-h,o-z)
4821       include 'DIMENSIONS'
4822       include 'COMMON.GEO'
4823       include 'COMMON.LOCAL'
4824       include 'COMMON.IOUNITS'
4825       common /sccalc/ time11,time12,time112,theti,it,nlobit
4826       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4827       double precision contr(maxlob)
4828       logical mixed
4829
4830       escloc_i=0.0D0
4831
4832       do j=1,3
4833         dersc(j)=0.0D0
4834       enddo
4835
4836       do j=1,nlobit
4837         do k=1,2
4838           z(k)=x(k)-censc(k,j,it)
4839         enddo
4840         z(3)=dwapi
4841         do k=1,3
4842           Axk=0.0D0
4843           do l=1,3
4844             Axk=Axk+gaussc(l,k,j,it)*z(l)
4845           enddo
4846           Ax(k,j)=Axk
4847         enddo
4848         expfac=0.0D0
4849         do k=1,3
4850           expfac=expfac+Ax(k,j)*z(k)
4851         enddo
4852         contr(j)=expfac
4853       enddo ! j
4854
4855 C As in the case of ebend, we want to avoid underflows in exponentiation and
4856 C subsequent NaNs and INFs in energy calculation.
4857 C Find the largest exponent
4858       emin=contr(1)
4859       do j=1,nlobit
4860         if (emin.gt.contr(j)) emin=contr(j)
4861       enddo
4862       emin=0.5D0*emin
4863
4864 C Compute the contribution to SC energy and derivatives
4865
4866       dersc12=0.0d0
4867       do j=1,nlobit
4868         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4869         escloc_i=escloc_i+expfac
4870         do k=1,2
4871           dersc(k)=dersc(k)+Ax(k,j)*expfac
4872         enddo
4873         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4874      &            +gaussc(1,2,j,it))*expfac
4875         dersc(3)=0.0d0
4876       enddo
4877
4878       dersc(1)=dersc(1)/cos(theti)**2
4879       dersc12=dersc12/cos(theti)**2
4880       escloci=-(dlog(escloc_i)-emin)
4881       do j=1,2
4882         dersc(j)=dersc(j)/escloc_i
4883       enddo
4884       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4885       return
4886       end
4887 #else
4888 c----------------------------------------------------------------------------------
4889       subroutine esc(escloc)
4890 C Calculate the local energy of a side chain and its derivatives in the
4891 C corresponding virtual-bond valence angles THETA and the spherical angles
4892 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4893 C added by Urszula Kozlowska. 07/11/2007
4894 C
4895       implicit real*8 (a-h,o-z)
4896       include 'DIMENSIONS'
4897       include 'sizesclu.dat'
4898       include 'COMMON.GEO'
4899       include 'COMMON.LOCAL'
4900       include 'COMMON.VAR'
4901       include 'COMMON.SCROT'
4902       include 'COMMON.INTERACT'
4903       include 'COMMON.DERIV'
4904       include 'COMMON.CHAIN'
4905       include 'COMMON.IOUNITS'
4906       include 'COMMON.NAMES'
4907       include 'COMMON.FFIELD'
4908       include 'COMMON.CONTROL'
4909       include 'COMMON.VECTORS'
4910       double precision x_prime(3),y_prime(3),z_prime(3)
4911      &    , sumene,dsc_i,dp2_i,x(65),
4912      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4913      &    de_dxx,de_dyy,de_dzz,de_dt
4914       double precision s1_t,s1_6_t,s2_t,s2_6_t
4915       double precision
4916      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4917      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4918      & dt_dCi(3),dt_dCi1(3)
4919       common /sccalc/ time11,time12,time112,theti,it,nlobit
4920       delta=0.02d0*pi
4921       escloc=0.0D0
4922       do i=loc_start,loc_end
4923         if (itype(i).eq.ntyp1) cycle
4924         costtab(i+1) =dcos(theta(i+1))
4925         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4926         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4927         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4928         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4929         cosfac=dsqrt(cosfac2)
4930         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4931         sinfac=dsqrt(sinfac2)
4932         it=iabs(itype(i))
4933         if (it.eq.10) goto 1
4934 c
4935 C  Compute the axes of tghe local cartesian coordinates system; store in
4936 c   x_prime, y_prime and z_prime
4937 c
4938         do j=1,3
4939           x_prime(j) = 0.00
4940           y_prime(j) = 0.00
4941           z_prime(j) = 0.00
4942         enddo
4943 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4944 C     &   dc_norm(3,i+nres)
4945         do j = 1,3
4946           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4947           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4948         enddo
4949         do j = 1,3
4950           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4951         enddo
4952 c       write (2,*) "i",i
4953 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4954 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4955 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4956 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4957 c      & " xy",scalar(x_prime(1),y_prime(1)),
4958 c      & " xz",scalar(x_prime(1),z_prime(1)),
4959 c      & " yy",scalar(y_prime(1),y_prime(1)),
4960 c      & " yz",scalar(y_prime(1),z_prime(1)),
4961 c      & " zz",scalar(z_prime(1),z_prime(1))
4962 c
4963 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4964 C to local coordinate system. Store in xx, yy, zz.
4965 c
4966         xx=0.0d0
4967         yy=0.0d0
4968         zz=0.0d0
4969         do j = 1,3
4970           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4971           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4972           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4973         enddo
4974
4975         xxtab(i)=xx
4976         yytab(i)=yy
4977         zztab(i)=zz
4978 C
4979 C Compute the energy of the ith side cbain
4980 C
4981 c        write (2,*) "xx",xx," yy",yy," zz",zz
4982         it=iabs(itype(i))
4983         do j = 1,65
4984           x(j) = sc_parmin(j,it)
4985         enddo
4986 #ifdef CHECK_COORD
4987 Cc diagnostics - remove later
4988         xx1 = dcos(alph(2))
4989         yy1 = dsin(alph(2))*dcos(omeg(2))
4990 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
4991         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4992         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4993      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4994      &    xx1,yy1,zz1
4995 C,"  --- ", xx_w,yy_w,zz_w
4996 c end diagnostics
4997 #endif
4998         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4999      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5000      &   + x(10)*yy*zz
5001         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5002      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5003      & + x(20)*yy*zz
5004         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5005      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5006      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5007      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5008      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5009      &  +x(40)*xx*yy*zz
5010         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5011      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5012      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5013      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5014      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5015      &  +x(60)*xx*yy*zz
5016         dsc_i   = 0.743d0+x(61)
5017         dp2_i   = 1.9d0+x(62)
5018         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5019      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5020         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5021      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5022         s1=(1+x(63))/(0.1d0 + dscp1)
5023         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5024         s2=(1+x(65))/(0.1d0 + dscp2)
5025         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5026         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5027      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5028 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5029 c     &   sumene4,
5030 c     &   dscp1,dscp2,sumene
5031 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5032         escloc = escloc + sumene
5033 c        write (2,*) "escloc",escloc
5034         if (.not. calc_grad) goto 1
5035 #ifdef DEBUG
5036 C
5037 C This section to check the numerical derivatives of the energy of ith side
5038 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5039 C #define DEBUG in the code to turn it on.
5040 C
5041         write (2,*) "sumene               =",sumene
5042         aincr=1.0d-7
5043         xxsave=xx
5044         xx=xx+aincr
5045         write (2,*) xx,yy,zz
5046         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5047         de_dxx_num=(sumenep-sumene)/aincr
5048         xx=xxsave
5049         write (2,*) "xx+ sumene from enesc=",sumenep
5050         yysave=yy
5051         yy=yy+aincr
5052         write (2,*) xx,yy,zz
5053         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5054         de_dyy_num=(sumenep-sumene)/aincr
5055         yy=yysave
5056         write (2,*) "yy+ sumene from enesc=",sumenep
5057         zzsave=zz
5058         zz=zz+aincr
5059         write (2,*) xx,yy,zz
5060         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5061         de_dzz_num=(sumenep-sumene)/aincr
5062         zz=zzsave
5063         write (2,*) "zz+ sumene from enesc=",sumenep
5064         costsave=cost2tab(i+1)
5065         sintsave=sint2tab(i+1)
5066         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5067         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5068         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5069         de_dt_num=(sumenep-sumene)/aincr
5070         write (2,*) " t+ sumene from enesc=",sumenep
5071         cost2tab(i+1)=costsave
5072         sint2tab(i+1)=sintsave
5073 C End of diagnostics section.
5074 #endif
5075 C
5076 C Compute the gradient of esc
5077 C
5078         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5079         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5080         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5081         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5082         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5083         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5084         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5085         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5086         pom1=(sumene3*sint2tab(i+1)+sumene1)
5087      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5088         pom2=(sumene4*cost2tab(i+1)+sumene2)
5089      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5090         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5091         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5092      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5093      &  +x(40)*yy*zz
5094         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5095         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5096      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5097      &  +x(60)*yy*zz
5098         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5099      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5100      &        +(pom1+pom2)*pom_dx
5101 #ifdef DEBUG
5102         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5103 #endif
5104 C
5105         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5106         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5107      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5108      &  +x(40)*xx*zz
5109         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5110         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5111      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5112      &  +x(59)*zz**2 +x(60)*xx*zz
5113         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5114      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5115      &        +(pom1-pom2)*pom_dy
5116 #ifdef DEBUG
5117         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5118 #endif
5119 C
5120         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5121      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5122      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5123      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5124      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5125      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5126      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5127      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5128 #ifdef DEBUG
5129         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5130 #endif
5131 C
5132         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5133      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5134      &  +pom1*pom_dt1+pom2*pom_dt2
5135 #ifdef DEBUG
5136         write(2,*), "de_dt = ", de_dt,de_dt_num
5137 #endif
5138 c
5139 C
5140        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5141        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5142        cosfac2xx=cosfac2*xx
5143        sinfac2yy=sinfac2*yy
5144        do k = 1,3
5145          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5146      &      vbld_inv(i+1)
5147          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5148      &      vbld_inv(i)
5149          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5150          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5151 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5152 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5153 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5154 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5155          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5156          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5157          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5158          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5159          dZZ_Ci1(k)=0.0d0
5160          dZZ_Ci(k)=0.0d0
5161          do j=1,3
5162            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5163      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5164            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5165      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5166          enddo
5167
5168          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5169          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5170          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5171 c
5172          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5173          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5174        enddo
5175
5176        do k=1,3
5177          dXX_Ctab(k,i)=dXX_Ci(k)
5178          dXX_C1tab(k,i)=dXX_Ci1(k)
5179          dYY_Ctab(k,i)=dYY_Ci(k)
5180          dYY_C1tab(k,i)=dYY_Ci1(k)
5181          dZZ_Ctab(k,i)=dZZ_Ci(k)
5182          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5183          dXX_XYZtab(k,i)=dXX_XYZ(k)
5184          dYY_XYZtab(k,i)=dYY_XYZ(k)
5185          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5186        enddo
5187
5188        do k = 1,3
5189 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5190 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5191 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5192 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5193 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5194 c     &    dt_dci(k)
5195 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5196 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5197          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5198      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5199          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5200      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5201          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5202      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5203        enddo
5204 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5205 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5206
5207 C to check gradient call subroutine check_grad
5208
5209     1 continue
5210       enddo
5211       return
5212       end
5213 #endif
5214 c------------------------------------------------------------------------------
5215       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5216 C
5217 C This procedure calculates two-body contact function g(rij) and its derivative:
5218 C
5219 C           eps0ij                                     !       x < -1
5220 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5221 C            0                                         !       x > 1
5222 C
5223 C where x=(rij-r0ij)/delta
5224 C
5225 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5226 C
5227       implicit none
5228       double precision rij,r0ij,eps0ij,fcont,fprimcont
5229       double precision x,x2,x4,delta
5230 c     delta=0.02D0*r0ij
5231 c      delta=0.2D0*r0ij
5232       x=(rij-r0ij)/delta
5233       if (x.lt.-1.0D0) then
5234         fcont=eps0ij
5235         fprimcont=0.0D0
5236       else if (x.le.1.0D0) then
5237         x2=x*x
5238         x4=x2*x2
5239         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5240         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5241       else
5242         fcont=0.0D0
5243         fprimcont=0.0D0
5244       endif
5245       return
5246       end
5247 c------------------------------------------------------------------------------
5248       subroutine splinthet(theti,delta,ss,ssder)
5249       implicit real*8 (a-h,o-z)
5250       include 'DIMENSIONS'
5251       include 'sizesclu.dat'
5252       include 'COMMON.VAR'
5253       include 'COMMON.GEO'
5254       thetup=pi-delta
5255       thetlow=delta
5256       if (theti.gt.pipol) then
5257         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5258       else
5259         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5260         ssder=-ssder
5261       endif
5262       return
5263       end
5264 c------------------------------------------------------------------------------
5265       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5266       implicit none
5267       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5268       double precision ksi,ksi2,ksi3,a1,a2,a3
5269       a1=fprim0*delta/(f1-f0)
5270       a2=3.0d0-2.0d0*a1
5271       a3=a1-2.0d0
5272       ksi=(x-x0)/delta
5273       ksi2=ksi*ksi
5274       ksi3=ksi2*ksi
5275       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5276       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5277       return
5278       end
5279 c------------------------------------------------------------------------------
5280       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5281       implicit none
5282       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5283       double precision ksi,ksi2,ksi3,a1,a2,a3
5284       ksi=(x-x0)/delta
5285       ksi2=ksi*ksi
5286       ksi3=ksi2*ksi
5287       a1=fprim0x*delta
5288       a2=3*(f1x-f0x)-2*fprim0x*delta
5289       a3=fprim0x*delta-2*(f1x-f0x)
5290       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5291       return
5292       end
5293 C-----------------------------------------------------------------------------
5294 #ifdef CRYST_TOR
5295 C-----------------------------------------------------------------------------
5296       subroutine etor(etors,edihcnstr,fact)
5297       implicit real*8 (a-h,o-z)
5298       include 'DIMENSIONS'
5299       include 'sizesclu.dat'
5300       include 'COMMON.VAR'
5301       include 'COMMON.GEO'
5302       include 'COMMON.LOCAL'
5303       include 'COMMON.TORSION'
5304       include 'COMMON.INTERACT'
5305       include 'COMMON.DERIV'
5306       include 'COMMON.CHAIN'
5307       include 'COMMON.NAMES'
5308       include 'COMMON.IOUNITS'
5309       include 'COMMON.FFIELD'
5310       include 'COMMON.TORCNSTR'
5311       logical lprn
5312 C Set lprn=.true. for debugging
5313       lprn=.false.
5314 c      lprn=.true.
5315       etors=0.0D0
5316       do i=iphi_start,iphi_end
5317         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5318      &      .or. itype(i).eq.ntyp1) cycle
5319         itori=itortyp(itype(i-2))
5320         itori1=itortyp(itype(i-1))
5321         phii=phi(i)
5322         gloci=0.0D0
5323 C Proline-Proline pair is a special case...
5324         if (itori.eq.3 .and. itori1.eq.3) then
5325           if (phii.gt.-dwapi3) then
5326             cosphi=dcos(3*phii)
5327             fac=1.0D0/(1.0D0-cosphi)
5328             etorsi=v1(1,3,3)*fac
5329             etorsi=etorsi+etorsi
5330             etors=etors+etorsi-v1(1,3,3)
5331             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5332           endif
5333           do j=1,3
5334             v1ij=v1(j+1,itori,itori1)
5335             v2ij=v2(j+1,itori,itori1)
5336             cosphi=dcos(j*phii)
5337             sinphi=dsin(j*phii)
5338             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5339             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5340           enddo
5341         else
5342           do j=1,nterm_old
5343             v1ij=v1(j,itori,itori1)
5344             v2ij=v2(j,itori,itori1)
5345             cosphi=dcos(j*phii)
5346             sinphi=dsin(j*phii)
5347             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5348             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5349           enddo
5350         endif
5351         if (lprn)
5352      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5353      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5354      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5355         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5356 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5357       enddo
5358 ! 6/20/98 - dihedral angle constraints
5359       edihcnstr=0.0d0
5360       do i=1,ndih_constr
5361         itori=idih_constr(i)
5362         phii=phi(itori)
5363         difi=phii-phi0(i)
5364         if (difi.gt.drange(i)) then
5365           difi=difi-drange(i)
5366           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5367           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5368         else if (difi.lt.-drange(i)) then
5369           difi=difi+drange(i)
5370           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5371           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5372         endif
5373 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5374 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5375       enddo
5376 !      write (iout,*) 'edihcnstr',edihcnstr
5377       return
5378       end
5379 c------------------------------------------------------------------------------
5380 #else
5381       subroutine etor(etors,edihcnstr,fact)
5382       implicit real*8 (a-h,o-z)
5383       include 'DIMENSIONS'
5384       include 'sizesclu.dat'
5385       include 'COMMON.VAR'
5386       include 'COMMON.GEO'
5387       include 'COMMON.LOCAL'
5388       include 'COMMON.TORSION'
5389       include 'COMMON.INTERACT'
5390       include 'COMMON.DERIV'
5391       include 'COMMON.CHAIN'
5392       include 'COMMON.NAMES'
5393       include 'COMMON.IOUNITS'
5394       include 'COMMON.FFIELD'
5395       include 'COMMON.TORCNSTR'
5396       logical lprn
5397 C Set lprn=.true. for debugging
5398       lprn=.false.
5399 c      lprn=.true.
5400       etors=0.0D0
5401       do i=iphi_start,iphi_end
5402         if (i.le.2) cycle
5403         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5404      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5405         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5406          if (iabs(itype(i)).eq.20) then
5407          iblock=2
5408          else
5409          iblock=1
5410          endif
5411         itori=itortyp(itype(i-2))
5412         itori1=itortyp(itype(i-1))
5413         phii=phi(i)
5414         gloci=0.0D0
5415 C Regular cosine and sine terms
5416         do j=1,nterm(itori,itori1,iblock)
5417           v1ij=v1(j,itori,itori1,iblock)
5418           v2ij=v2(j,itori,itori1,iblock)
5419           cosphi=dcos(j*phii)
5420           sinphi=dsin(j*phii)
5421           etors=etors+v1ij*cosphi+v2ij*sinphi
5422           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5423         enddo
5424 C Lorentz terms
5425 C                         v1
5426 C  E = SUM ----------------------------------- - v1
5427 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5428 C
5429         cosphi=dcos(0.5d0*phii)
5430         sinphi=dsin(0.5d0*phii)
5431         do j=1,nlor(itori,itori1,iblock)
5432           vl1ij=vlor1(j,itori,itori1)
5433           vl2ij=vlor2(j,itori,itori1)
5434           vl3ij=vlor3(j,itori,itori1)
5435           pom=vl2ij*cosphi+vl3ij*sinphi
5436           pom1=1.0d0/(pom*pom+1.0d0)
5437           etors=etors+vl1ij*pom1
5438           pom=-pom*pom1*pom1
5439           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5440         enddo
5441 C Subtract the constant term
5442         etors=etors-v0(itori,itori1,iblock)
5443         if (lprn)
5444      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5445      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5446      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5447         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5448 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5449  1215   continue
5450       enddo
5451 ! 6/20/98 - dihedral angle constraints
5452       edihcnstr=0.0d0
5453       do i=1,ndih_constr
5454         itori=idih_constr(i)
5455         phii=phi(itori)
5456         difi=pinorm(phii-phi0(i))
5457         edihi=0.0d0
5458         if (difi.gt.drange(i)) then
5459           difi=difi-drange(i)
5460           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5461           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5462           edihi=0.25d0*ftors(i)*difi**4
5463         else if (difi.lt.-drange(i)) then
5464           difi=difi+drange(i)
5465           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5466           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5467           edihi=0.25d0*ftors(i)*difi**4
5468         else
5469           difi=0.0d0
5470         endif
5471 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5472 c     &    drange(i),edihi
5473 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5474 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5475       enddo
5476 !      write (iout,*) 'edihcnstr',edihcnstr
5477       return
5478       end
5479 c----------------------------------------------------------------------------
5480       subroutine etor_d(etors_d,fact2)
5481 C 6/23/01 Compute double torsional energy
5482       implicit real*8 (a-h,o-z)
5483       include 'DIMENSIONS'
5484       include 'sizesclu.dat'
5485       include 'COMMON.VAR'
5486       include 'COMMON.GEO'
5487       include 'COMMON.LOCAL'
5488       include 'COMMON.TORSION'
5489       include 'COMMON.INTERACT'
5490       include 'COMMON.DERIV'
5491       include 'COMMON.CHAIN'
5492       include 'COMMON.NAMES'
5493       include 'COMMON.IOUNITS'
5494       include 'COMMON.FFIELD'
5495       include 'COMMON.TORCNSTR'
5496       logical lprn
5497 C Set lprn=.true. for debugging
5498       lprn=.false.
5499 c     lprn=.true.
5500       etors_d=0.0D0
5501       do i=iphi_start,iphi_end-1
5502         if (i.le.3) cycle
5503          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5504      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5505      &  (itype(i+1).eq.ntyp1)) cycle
5506         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5507      &     goto 1215
5508         itori=itortyp(itype(i-2))
5509         itori1=itortyp(itype(i-1))
5510         itori2=itortyp(itype(i))
5511         phii=phi(i)
5512         phii1=phi(i+1)
5513         gloci1=0.0D0
5514         gloci2=0.0D0
5515         iblock=1
5516         if (iabs(itype(i+1)).eq.20) iblock=2
5517 C Regular cosine and sine terms
5518        do j=1,ntermd_1(itori,itori1,itori2,iblock)
5519           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5520           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5521           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5522           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5523           cosphi1=dcos(j*phii)
5524           sinphi1=dsin(j*phii)
5525           cosphi2=dcos(j*phii1)
5526           sinphi2=dsin(j*phii1)
5527           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5528      &     v2cij*cosphi2+v2sij*sinphi2
5529           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5530           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5531         enddo
5532         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5533           do l=1,k-1
5534             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5535             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5536             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5537             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5538             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5539             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5540             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5541             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5542             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5543      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5544             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5545      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5546             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5547      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5548           enddo
5549         enddo
5550         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5551         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5552  1215   continue
5553       enddo
5554       return
5555       end
5556 #endif
5557 c------------------------------------------------------------------------------
5558       subroutine eback_sc_corr(esccor)
5559 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5560 c        conformational states; temporarily implemented as differences
5561 c        between UNRES torsional potentials (dependent on three types of
5562 c        residues) and the torsional potentials dependent on all 20 types
5563 c        of residues computed from AM1 energy surfaces of terminally-blocked
5564 c        amino-acid residues.
5565       implicit real*8 (a-h,o-z)
5566       include 'DIMENSIONS'
5567       include 'sizesclu.dat'
5568       include 'COMMON.VAR'
5569       include 'COMMON.GEO'
5570       include 'COMMON.LOCAL'
5571       include 'COMMON.TORSION'
5572       include 'COMMON.SCCOR'
5573       include 'COMMON.INTERACT'
5574       include 'COMMON.DERIV'
5575       include 'COMMON.CHAIN'
5576       include 'COMMON.NAMES'
5577       include 'COMMON.IOUNITS'
5578       include 'COMMON.FFIELD'
5579       include 'COMMON.CONTROL'
5580       logical lprn
5581 C Set lprn=.true. for debugging
5582       lprn=.false.
5583 c      lprn=.true.
5584 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5585       esccor=0.0D0
5586       do i=itau_start,itau_end
5587         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5588         esccor_ii=0.0D0
5589         isccori=isccortyp(itype(i-2))
5590         isccori1=isccortyp(itype(i-1))
5591         phii=phi(i)
5592         do intertyp=1,3 !intertyp
5593 cc Added 09 May 2012 (Adasko)
5594 cc  Intertyp means interaction type of backbone mainchain correlation:
5595 c   1 = SC...Ca...Ca...Ca
5596 c   2 = Ca...Ca...Ca...SC
5597 c   3 = SC...Ca...Ca...SCi
5598         gloci=0.0D0
5599         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5600      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5601      &      (itype(i-1).eq.ntyp1)))
5602      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5603      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5604      &     .or.(itype(i).eq.ntyp1)))
5605      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5606      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5607      &      (itype(i-3).eq.ntyp1)))) cycle
5608         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5609         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5610      & cycle
5611        do j=1,nterm_sccor(isccori,isccori1)
5612           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5613           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5614           cosphi=dcos(j*tauangle(intertyp,i))
5615           sinphi=dsin(j*tauangle(intertyp,i))
5616            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5617 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5618          enddo
5619 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5620 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
5621         if (lprn)
5622      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5623      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5624      &  (v1sccor(j,1,itori,itori1),j=1,6),
5625      &  (v2sccor(j,1,itori,itori1),j=1,6)
5626         gsccor_loc(i-3)=gloci
5627        enddo !intertyp
5628       enddo
5629       return
5630       end
5631 c------------------------------------------------------------------------------
5632       subroutine multibody(ecorr)
5633 C This subroutine calculates multi-body contributions to energy following
5634 C the idea of Skolnick et al. If side chains I and J make a contact and
5635 C at the same time side chains I+1 and J+1 make a contact, an extra
5636 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5637       implicit real*8 (a-h,o-z)
5638       include 'DIMENSIONS'
5639       include 'COMMON.IOUNITS'
5640       include 'COMMON.DERIV'
5641       include 'COMMON.INTERACT'
5642       include 'COMMON.CONTACTS'
5643       double precision gx(3),gx1(3)
5644       logical lprn
5645
5646 C Set lprn=.true. for debugging
5647       lprn=.false.
5648
5649       if (lprn) then
5650         write (iout,'(a)') 'Contact function values:'
5651         do i=nnt,nct-2
5652           write (iout,'(i2,20(1x,i2,f10.5))')
5653      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5654         enddo
5655       endif
5656       ecorr=0.0D0
5657       do i=nnt,nct
5658         do j=1,3
5659           gradcorr(j,i)=0.0D0
5660           gradxorr(j,i)=0.0D0
5661         enddo
5662       enddo
5663       do i=nnt,nct-2
5664
5665         DO ISHIFT = 3,4
5666
5667         i1=i+ishift
5668         num_conti=num_cont(i)
5669         num_conti1=num_cont(i1)
5670         do jj=1,num_conti
5671           j=jcont(jj,i)
5672           do kk=1,num_conti1
5673             j1=jcont(kk,i1)
5674             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5675 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5676 cd   &                   ' ishift=',ishift
5677 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5678 C The system gains extra energy.
5679               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5680             endif   ! j1==j+-ishift
5681           enddo     ! kk
5682         enddo       ! jj
5683
5684         ENDDO ! ISHIFT
5685
5686       enddo         ! i
5687       return
5688       end
5689 c------------------------------------------------------------------------------
5690       double precision function esccorr(i,j,k,l,jj,kk)
5691       implicit real*8 (a-h,o-z)
5692       include 'DIMENSIONS'
5693       include 'COMMON.IOUNITS'
5694       include 'COMMON.DERIV'
5695       include 'COMMON.INTERACT'
5696       include 'COMMON.CONTACTS'
5697       double precision gx(3),gx1(3)
5698       logical lprn
5699       lprn=.false.
5700       eij=facont(jj,i)
5701       ekl=facont(kk,k)
5702 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5703 C Calculate the multi-body contribution to energy.
5704 C Calculate multi-body contributions to the gradient.
5705 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5706 cd   & k,l,(gacont(m,kk,k),m=1,3)
5707       do m=1,3
5708         gx(m) =ekl*gacont(m,jj,i)
5709         gx1(m)=eij*gacont(m,kk,k)
5710         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5711         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5712         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5713         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5714       enddo
5715       do m=i,j-1
5716         do ll=1,3
5717           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5718         enddo
5719       enddo
5720       do m=k,l-1
5721         do ll=1,3
5722           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5723         enddo
5724       enddo
5725       esccorr=-eij*ekl
5726       return
5727       end
5728 c------------------------------------------------------------------------------
5729 #ifdef MPL
5730       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5731       implicit real*8 (a-h,o-z)
5732       include 'DIMENSIONS'
5733       integer dimen1,dimen2,atom,indx
5734       double precision buffer(dimen1,dimen2)
5735       double precision zapas
5736       common /contacts_hb/ zapas(3,20,maxres,7),
5737      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5738      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5739       num_kont=num_cont_hb(atom)
5740       do i=1,num_kont
5741         do k=1,7
5742           do j=1,3
5743             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5744           enddo ! j
5745         enddo ! k
5746         buffer(i,indx+22)=facont_hb(i,atom)
5747         buffer(i,indx+23)=ees0p(i,atom)
5748         buffer(i,indx+24)=ees0m(i,atom)
5749         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5750       enddo ! i
5751       buffer(1,indx+26)=dfloat(num_kont)
5752       return
5753       end
5754 c------------------------------------------------------------------------------
5755       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5756       implicit real*8 (a-h,o-z)
5757       include 'DIMENSIONS'
5758       integer dimen1,dimen2,atom,indx
5759       double precision buffer(dimen1,dimen2)
5760       double precision zapas
5761       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5762      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5763      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5764       num_kont=buffer(1,indx+26)
5765       num_kont_old=num_cont_hb(atom)
5766       num_cont_hb(atom)=num_kont+num_kont_old
5767       do i=1,num_kont
5768         ii=i+num_kont_old
5769         do k=1,7
5770           do j=1,3
5771             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5772           enddo ! j
5773         enddo ! k
5774         facont_hb(ii,atom)=buffer(i,indx+22)
5775         ees0p(ii,atom)=buffer(i,indx+23)
5776         ees0m(ii,atom)=buffer(i,indx+24)
5777         jcont_hb(ii,atom)=buffer(i,indx+25)
5778       enddo ! i
5779       return
5780       end
5781 c------------------------------------------------------------------------------
5782 #endif
5783       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5784 C This subroutine calculates multi-body contributions to hydrogen-bonding
5785       implicit real*8 (a-h,o-z)
5786       include 'DIMENSIONS'
5787       include 'sizesclu.dat'
5788       include 'COMMON.IOUNITS'
5789 #ifdef MPL
5790       include 'COMMON.INFO'
5791 #endif
5792       include 'COMMON.FFIELD'
5793       include 'COMMON.DERIV'
5794       include 'COMMON.INTERACT'
5795       include 'COMMON.CONTACTS'
5796 #ifdef MPL
5797       parameter (max_cont=maxconts)
5798       parameter (max_dim=2*(8*3+2))
5799       parameter (msglen1=max_cont*max_dim*4)
5800       parameter (msglen2=2*msglen1)
5801       integer source,CorrelType,CorrelID,Error
5802       double precision buffer(max_cont,max_dim)
5803 #endif
5804       double precision gx(3),gx1(3)
5805       logical lprn,ldone
5806
5807 C Set lprn=.true. for debugging
5808       lprn=.false.
5809 #ifdef MPL
5810       n_corr=0
5811       n_corr1=0
5812       if (fgProcs.le.1) goto 30
5813       if (lprn) then
5814         write (iout,'(a)') 'Contact function values:'
5815         do i=nnt,nct-2
5816           write (iout,'(2i3,50(1x,i2,f5.2))')
5817      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5818      &    j=1,num_cont_hb(i))
5819         enddo
5820       endif
5821 C Caution! Following code assumes that electrostatic interactions concerning
5822 C a given atom are split among at most two processors!
5823       CorrelType=477
5824       CorrelID=MyID+1
5825       ldone=.false.
5826       do i=1,max_cont
5827         do j=1,max_dim
5828           buffer(i,j)=0.0D0
5829         enddo
5830       enddo
5831       mm=mod(MyRank,2)
5832 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5833       if (mm) 20,20,10
5834    10 continue
5835 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5836       if (MyRank.gt.0) then
5837 C Send correlation contributions to the preceding processor
5838         msglen=msglen1
5839         nn=num_cont_hb(iatel_s)
5840         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5841 cd      write (iout,*) 'The BUFFER array:'
5842 cd      do i=1,nn
5843 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5844 cd      enddo
5845         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5846           msglen=msglen2
5847             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5848 C Clear the contacts of the atom passed to the neighboring processor
5849         nn=num_cont_hb(iatel_s+1)
5850 cd      do i=1,nn
5851 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5852 cd      enddo
5853             num_cont_hb(iatel_s)=0
5854         endif
5855 cd      write (iout,*) 'Processor ',MyID,MyRank,
5856 cd   & ' is sending correlation contribution to processor',MyID-1,
5857 cd   & ' msglen=',msglen
5858 cd      write (*,*) 'Processor ',MyID,MyRank,
5859 cd   & ' is sending correlation contribution to processor',MyID-1,
5860 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5861         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5862 cd      write (iout,*) 'Processor ',MyID,
5863 cd   & ' has sent correlation contribution to processor',MyID-1,
5864 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5865 cd      write (*,*) 'Processor ',MyID,
5866 cd   & ' has sent correlation contribution to processor',MyID-1,
5867 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5868         msglen=msglen1
5869       endif ! (MyRank.gt.0)
5870       if (ldone) goto 30
5871       ldone=.true.
5872    20 continue
5873 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5874       if (MyRank.lt.fgProcs-1) then
5875 C Receive correlation contributions from the next processor
5876         msglen=msglen1
5877         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5878 cd      write (iout,*) 'Processor',MyID,
5879 cd   & ' is receiving correlation contribution from processor',MyID+1,
5880 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5881 cd      write (*,*) 'Processor',MyID,
5882 cd   & ' is receiving correlation contribution from processor',MyID+1,
5883 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5884         nbytes=-1
5885         do while (nbytes.le.0)
5886           call mp_probe(MyID+1,CorrelType,nbytes)
5887         enddo
5888 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5889         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5890 cd      write (iout,*) 'Processor',MyID,
5891 cd   & ' has received correlation contribution from processor',MyID+1,
5892 cd   & ' msglen=',msglen,' nbytes=',nbytes
5893 cd      write (iout,*) 'The received BUFFER array:'
5894 cd      do i=1,max_cont
5895 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5896 cd      enddo
5897         if (msglen.eq.msglen1) then
5898           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5899         else if (msglen.eq.msglen2)  then
5900           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5901           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5902         else
5903           write (iout,*)
5904      & 'ERROR!!!! message length changed while processing correlations.'
5905           write (*,*)
5906      & 'ERROR!!!! message length changed while processing correlations.'
5907           call mp_stopall(Error)
5908         endif ! msglen.eq.msglen1
5909       endif ! MyRank.lt.fgProcs-1
5910       if (ldone) goto 30
5911       ldone=.true.
5912       goto 10
5913    30 continue
5914 #endif
5915       if (lprn) then
5916         write (iout,'(a)') 'Contact function values:'
5917         do i=nnt,nct-2
5918           write (iout,'(2i3,50(1x,i2,f5.2))')
5919      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5920      &    j=1,num_cont_hb(i))
5921         enddo
5922       endif
5923       ecorr=0.0D0
5924 C Remove the loop below after debugging !!!
5925       do i=nnt,nct
5926         do j=1,3
5927           gradcorr(j,i)=0.0D0
5928           gradxorr(j,i)=0.0D0
5929         enddo
5930       enddo
5931 C Calculate the local-electrostatic correlation terms
5932       do i=iatel_s,iatel_e+1
5933         i1=i+1
5934         num_conti=num_cont_hb(i)
5935         num_conti1=num_cont_hb(i+1)
5936         do jj=1,num_conti
5937           j=jcont_hb(jj,i)
5938           do kk=1,num_conti1
5939             j1=jcont_hb(kk,i1)
5940 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5941 c     &         ' jj=',jj,' kk=',kk
5942             if (j1.eq.j+1 .or. j1.eq.j-1) then
5943 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5944 C The system gains extra energy.
5945               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5946               n_corr=n_corr+1
5947             else if (j1.eq.j) then
5948 C Contacts I-J and I-(J+1) occur simultaneously.
5949 C The system loses extra energy.
5950 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5951             endif
5952           enddo ! kk
5953           do kk=1,num_conti
5954             j1=jcont_hb(kk,i)
5955 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5956 c    &         ' jj=',jj,' kk=',kk
5957             if (j1.eq.j+1) then
5958 C Contacts I-J and (I+1)-J occur simultaneously.
5959 C The system loses extra energy.
5960 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5961             endif ! j1==j+1
5962           enddo ! kk
5963         enddo ! jj
5964       enddo ! i
5965       return
5966       end
5967 c------------------------------------------------------------------------------
5968       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5969      &  n_corr1)
5970 C This subroutine calculates multi-body contributions to hydrogen-bonding
5971       implicit real*8 (a-h,o-z)
5972       include 'DIMENSIONS'
5973       include 'sizesclu.dat'
5974       include 'COMMON.IOUNITS'
5975 #ifdef MPL
5976       include 'COMMON.INFO'
5977 #endif
5978       include 'COMMON.FFIELD'
5979       include 'COMMON.DERIV'
5980       include 'COMMON.INTERACT'
5981       include 'COMMON.CONTACTS'
5982 #ifdef MPL
5983       parameter (max_cont=maxconts)
5984       parameter (max_dim=2*(8*3+2))
5985       parameter (msglen1=max_cont*max_dim*4)
5986       parameter (msglen2=2*msglen1)
5987       integer source,CorrelType,CorrelID,Error
5988       double precision buffer(max_cont,max_dim)
5989 #endif
5990       double precision gx(3),gx1(3)
5991       logical lprn,ldone
5992
5993 C Set lprn=.true. for debugging
5994       lprn=.false.
5995       eturn6=0.0d0
5996 #ifdef MPL
5997       n_corr=0
5998       n_corr1=0
5999       if (fgProcs.le.1) goto 30
6000       if (lprn) then
6001         write (iout,'(a)') 'Contact function values:'
6002         do i=nnt,nct-2
6003           write (iout,'(2i3,50(1x,i2,f5.2))')
6004      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6005      &    j=1,num_cont_hb(i))
6006         enddo
6007       endif
6008 C Caution! Following code assumes that electrostatic interactions concerning
6009 C a given atom are split among at most two processors!
6010       CorrelType=477
6011       CorrelID=MyID+1
6012       ldone=.false.
6013       do i=1,max_cont
6014         do j=1,max_dim
6015           buffer(i,j)=0.0D0
6016         enddo
6017       enddo
6018       mm=mod(MyRank,2)
6019 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6020       if (mm) 20,20,10
6021    10 continue
6022 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6023       if (MyRank.gt.0) then
6024 C Send correlation contributions to the preceding processor
6025         msglen=msglen1
6026         nn=num_cont_hb(iatel_s)
6027         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6028 cd      write (iout,*) 'The BUFFER array:'
6029 cd      do i=1,nn
6030 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6031 cd      enddo
6032         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6033           msglen=msglen2
6034             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6035 C Clear the contacts of the atom passed to the neighboring processor
6036         nn=num_cont_hb(iatel_s+1)
6037 cd      do i=1,nn
6038 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6039 cd      enddo
6040             num_cont_hb(iatel_s)=0
6041         endif
6042 cd      write (iout,*) 'Processor ',MyID,MyRank,
6043 cd   & ' is sending correlation contribution to processor',MyID-1,
6044 cd   & ' msglen=',msglen
6045 cd      write (*,*) 'Processor ',MyID,MyRank,
6046 cd   & ' is sending correlation contribution to processor',MyID-1,
6047 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6048         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6049 cd      write (iout,*) 'Processor ',MyID,
6050 cd   & ' has sent correlation contribution to processor',MyID-1,
6051 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6052 cd      write (*,*) 'Processor ',MyID,
6053 cd   & ' has sent correlation contribution to processor',MyID-1,
6054 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6055         msglen=msglen1
6056       endif ! (MyRank.gt.0)
6057       if (ldone) goto 30
6058       ldone=.true.
6059    20 continue
6060 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6061       if (MyRank.lt.fgProcs-1) then
6062 C Receive correlation contributions from the next processor
6063         msglen=msglen1
6064         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6065 cd      write (iout,*) 'Processor',MyID,
6066 cd   & ' is receiving correlation contribution from processor',MyID+1,
6067 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6068 cd      write (*,*) 'Processor',MyID,
6069 cd   & ' is receiving correlation contribution from processor',MyID+1,
6070 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6071         nbytes=-1
6072         do while (nbytes.le.0)
6073           call mp_probe(MyID+1,CorrelType,nbytes)
6074         enddo
6075 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6076         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6077 cd      write (iout,*) 'Processor',MyID,
6078 cd   & ' has received correlation contribution from processor',MyID+1,
6079 cd   & ' msglen=',msglen,' nbytes=',nbytes
6080 cd      write (iout,*) 'The received BUFFER array:'
6081 cd      do i=1,max_cont
6082 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6083 cd      enddo
6084         if (msglen.eq.msglen1) then
6085           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6086         else if (msglen.eq.msglen2)  then
6087           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6088           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6089         else
6090           write (iout,*)
6091      & 'ERROR!!!! message length changed while processing correlations.'
6092           write (*,*)
6093      & 'ERROR!!!! message length changed while processing correlations.'
6094           call mp_stopall(Error)
6095         endif ! msglen.eq.msglen1
6096       endif ! MyRank.lt.fgProcs-1
6097       if (ldone) goto 30
6098       ldone=.true.
6099       goto 10
6100    30 continue
6101 #endif
6102       if (lprn) then
6103         write (iout,'(a)') 'Contact function values:'
6104         do i=nnt,nct-2
6105           write (iout,'(2i3,50(1x,i2,f5.2))')
6106      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6107      &    j=1,num_cont_hb(i))
6108         enddo
6109       endif
6110       ecorr=0.0D0
6111       ecorr5=0.0d0
6112       ecorr6=0.0d0
6113 C Remove the loop below after debugging !!!
6114       do i=nnt,nct
6115         do j=1,3
6116           gradcorr(j,i)=0.0D0
6117           gradxorr(j,i)=0.0D0
6118         enddo
6119       enddo
6120 C Calculate the dipole-dipole interaction energies
6121       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6122       do i=iatel_s,iatel_e+1
6123         num_conti=num_cont_hb(i)
6124         do jj=1,num_conti
6125           j=jcont_hb(jj,i)
6126           call dipole(i,j,jj)
6127         enddo
6128       enddo
6129       endif
6130 C Calculate the local-electrostatic correlation terms
6131       do i=iatel_s,iatel_e+1
6132         i1=i+1
6133         num_conti=num_cont_hb(i)
6134         num_conti1=num_cont_hb(i+1)
6135         do jj=1,num_conti
6136           j=jcont_hb(jj,i)
6137           do kk=1,num_conti1
6138             j1=jcont_hb(kk,i1)
6139 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6140 c     &         ' jj=',jj,' kk=',kk
6141             if (j1.eq.j+1 .or. j1.eq.j-1) then
6142 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6143 C The system gains extra energy.
6144               n_corr=n_corr+1
6145               sqd1=dsqrt(d_cont(jj,i))
6146               sqd2=dsqrt(d_cont(kk,i1))
6147               sred_geom = sqd1*sqd2
6148               IF (sred_geom.lt.cutoff_corr) THEN
6149                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6150      &            ekont,fprimcont)
6151 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6152 c     &         ' jj=',jj,' kk=',kk
6153                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6154                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6155                 do l=1,3
6156                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6157                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6158                 enddo
6159                 n_corr1=n_corr1+1
6160 cd               write (iout,*) 'sred_geom=',sred_geom,
6161 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6162                 call calc_eello(i,j,i+1,j1,jj,kk)
6163                 if (wcorr4.gt.0.0d0)
6164      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6165                 if (wcorr5.gt.0.0d0)
6166      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6167 c                print *,"wcorr5",ecorr5
6168 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6169 cd                write(2,*)'ijkl',i,j,i+1,j1
6170                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6171      &               .or. wturn6.eq.0.0d0))then
6172 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6173                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6174 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6175 cd     &            'ecorr6=',ecorr6
6176 cd                write (iout,'(4e15.5)') sred_geom,
6177 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6178 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6179 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6180                 else if (wturn6.gt.0.0d0
6181      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6182 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6183                   eturn6=eturn6+eello_turn6(i,jj,kk)
6184 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6185                 endif
6186               ENDIF
6187 1111          continue
6188             else if (j1.eq.j) then
6189 C Contacts I-J and I-(J+1) occur simultaneously.
6190 C The system loses extra energy.
6191 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6192             endif
6193           enddo ! kk
6194           do kk=1,num_conti
6195             j1=jcont_hb(kk,i)
6196 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6197 c    &         ' jj=',jj,' kk=',kk
6198             if (j1.eq.j+1) then
6199 C Contacts I-J and (I+1)-J occur simultaneously.
6200 C The system loses extra energy.
6201 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6202             endif ! j1==j+1
6203           enddo ! kk
6204         enddo ! jj
6205       enddo ! i
6206       return
6207       end
6208 c------------------------------------------------------------------------------
6209       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6210       implicit real*8 (a-h,o-z)
6211       include 'DIMENSIONS'
6212       include 'COMMON.IOUNITS'
6213       include 'COMMON.DERIV'
6214       include 'COMMON.INTERACT'
6215       include 'COMMON.CONTACTS'
6216       include 'COMMON.SHIELD'
6217
6218       double precision gx(3),gx1(3)
6219       logical lprn
6220       lprn=.false.
6221       eij=facont_hb(jj,i)
6222       ekl=facont_hb(kk,k)
6223       ees0pij=ees0p(jj,i)
6224       ees0pkl=ees0p(kk,k)
6225       ees0mij=ees0m(jj,i)
6226       ees0mkl=ees0m(kk,k)
6227       ekont=eij*ekl
6228       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6229 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6230 C Following 4 lines for diagnostics.
6231 cd    ees0pkl=0.0D0
6232 cd    ees0pij=1.0D0
6233 cd    ees0mkl=0.0D0
6234 cd    ees0mij=1.0D0
6235 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6236 c    &   ' and',k,l
6237 c     write (iout,*)'Contacts have occurred for peptide groups',
6238 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6239 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6240 C Calculate the multi-body contribution to energy.
6241       ecorr=ecorr+ekont*ees
6242       if (calc_grad) then
6243 C Calculate multi-body contributions to the gradient.
6244       do ll=1,3
6245         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6246         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6247      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6248      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6249         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6250      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6251      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6252         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6253         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6254      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6255      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6256         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6257      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6258      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6259       enddo
6260       do m=i+1,j-1
6261         do ll=1,3
6262           gradcorr(ll,m)=gradcorr(ll,m)+
6263      &     ees*ekl*gacont_hbr(ll,jj,i)-
6264      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6265      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6266         enddo
6267       enddo
6268       do m=k+1,l-1
6269         do ll=1,3
6270           gradcorr(ll,m)=gradcorr(ll,m)+
6271      &     ees*eij*gacont_hbr(ll,kk,k)-
6272      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6273      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6274         enddo
6275       enddo
6276       if (shield_mode.gt.0) then
6277        j=ees0plist(jj,i)
6278        l=ees0plist(kk,k)
6279 C        print *,i,j,fac_shield(i),fac_shield(j),
6280 C     &fac_shield(k),fac_shield(l)
6281         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6282      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6283           do ilist=1,ishield_list(i)
6284            iresshield=shield_list(ilist,i)
6285            do m=1,3
6286            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6287 C     &      *2.0
6288            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6289      &              rlocshield
6290      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6291             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6292      &+rlocshield
6293            enddo
6294           enddo
6295           do ilist=1,ishield_list(j)
6296            iresshield=shield_list(ilist,j)
6297            do m=1,3
6298            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6299 C     &     *2.0
6300            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6301      &              rlocshield
6302      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6303            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6304      &     +rlocshield
6305            enddo
6306           enddo
6307           do ilist=1,ishield_list(k)
6308            iresshield=shield_list(ilist,k)
6309            do m=1,3
6310            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6311 C     &     *2.0
6312            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6313      &              rlocshield
6314      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6315            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6316      &     +rlocshield
6317            enddo
6318           enddo
6319           do ilist=1,ishield_list(l)
6320            iresshield=shield_list(ilist,l)
6321            do m=1,3
6322            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6323 C     &     *2.0
6324            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6325      &              rlocshield
6326      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6327            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6328      &     +rlocshield
6329            enddo
6330           enddo
6331 C          print *,gshieldx(m,iresshield)
6332           do m=1,3
6333             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6334      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6335             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6336      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6337             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6338      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6339             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6340      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6341
6342             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6343      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6344             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6345      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6346             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6347      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6348             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6349      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6350
6351            enddo
6352       endif
6353       endif
6354       endif
6355       ehbcorr=ekont*ees
6356       return
6357       end
6358 C---------------------------------------------------------------------------
6359       subroutine dipole(i,j,jj)
6360       implicit real*8 (a-h,o-z)
6361       include 'DIMENSIONS'
6362       include 'sizesclu.dat'
6363       include 'COMMON.IOUNITS'
6364       include 'COMMON.CHAIN'
6365       include 'COMMON.FFIELD'
6366       include 'COMMON.DERIV'
6367       include 'COMMON.INTERACT'
6368       include 'COMMON.CONTACTS'
6369       include 'COMMON.TORSION'
6370       include 'COMMON.VAR'
6371       include 'COMMON.GEO'
6372       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6373      &  auxmat(2,2)
6374       iti1 = itortyp(itype(i+1))
6375       if (j.lt.nres-1) then
6376         if (itype(j).le.ntyp) then
6377           itj1 = itortyp(itype(j+1))
6378         else
6379           itj1=ntortyp+1
6380         endif
6381       else
6382         itj1=ntortyp+1
6383       endif
6384       do iii=1,2
6385         dipi(iii,1)=Ub2(iii,i)
6386         dipderi(iii)=Ub2der(iii,i)
6387         dipi(iii,2)=b1(iii,iti1)
6388         dipj(iii,1)=Ub2(iii,j)
6389         dipderj(iii)=Ub2der(iii,j)
6390         dipj(iii,2)=b1(iii,itj1)
6391       enddo
6392       kkk=0
6393       do iii=1,2
6394         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6395         do jjj=1,2
6396           kkk=kkk+1
6397           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6398         enddo
6399       enddo
6400       if (.not.calc_grad) return
6401       do kkk=1,5
6402         do lll=1,3
6403           mmm=0
6404           do iii=1,2
6405             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6406      &        auxvec(1))
6407             do jjj=1,2
6408               mmm=mmm+1
6409               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6410             enddo
6411           enddo
6412         enddo
6413       enddo
6414       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6415       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6416       do iii=1,2
6417         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6418       enddo
6419       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6420       do iii=1,2
6421         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6422       enddo
6423       return
6424       end
6425 C---------------------------------------------------------------------------
6426       subroutine calc_eello(i,j,k,l,jj,kk)
6427 C
6428 C This subroutine computes matrices and vectors needed to calculate
6429 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6430 C
6431       implicit real*8 (a-h,o-z)
6432       include 'DIMENSIONS'
6433       include 'sizesclu.dat'
6434       include 'COMMON.IOUNITS'
6435       include 'COMMON.CHAIN'
6436       include 'COMMON.DERIV'
6437       include 'COMMON.INTERACT'
6438       include 'COMMON.CONTACTS'
6439       include 'COMMON.TORSION'
6440       include 'COMMON.VAR'
6441       include 'COMMON.GEO'
6442       include 'COMMON.FFIELD'
6443       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6444      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6445       logical lprn
6446       common /kutas/ lprn
6447 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6448 cd     & ' jj=',jj,' kk=',kk
6449 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6450       do iii=1,2
6451         do jjj=1,2
6452           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6453           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6454         enddo
6455       enddo
6456       call transpose2(aa1(1,1),aa1t(1,1))
6457       call transpose2(aa2(1,1),aa2t(1,1))
6458       do kkk=1,5
6459         do lll=1,3
6460           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6461      &      aa1tder(1,1,lll,kkk))
6462           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6463      &      aa2tder(1,1,lll,kkk))
6464         enddo
6465       enddo
6466       if (l.eq.j+1) then
6467 C parallel orientation of the two CA-CA-CA frames.
6468 c        if (i.gt.1) then
6469         if (i.gt.1 .and. itype(i).le.ntyp) then
6470           iti=itortyp(itype(i))
6471         else
6472           iti=ntortyp+1
6473         endif
6474         itk1=itortyp(itype(k+1))
6475         itj=itortyp(itype(j))
6476 c        if (l.lt.nres-1) then
6477         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6478           itl1=itortyp(itype(l+1))
6479         else
6480           itl1=ntortyp+1
6481         endif
6482 C A1 kernel(j+1) A2T
6483 cd        do iii=1,2
6484 cd          write (iout,'(3f10.5,5x,3f10.5)')
6485 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6486 cd        enddo
6487         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6488      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6489      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6490 C Following matrices are needed only for 6-th order cumulants
6491         IF (wcorr6.gt.0.0d0) THEN
6492         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6493      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6494      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6495         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6496      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6497      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6498      &   ADtEAderx(1,1,1,1,1,1))
6499         lprn=.false.
6500         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6501      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6502      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6503      &   ADtEA1derx(1,1,1,1,1,1))
6504         ENDIF
6505 C End 6-th order cumulants
6506 cd        lprn=.false.
6507 cd        if (lprn) then
6508 cd        write (2,*) 'In calc_eello6'
6509 cd        do iii=1,2
6510 cd          write (2,*) 'iii=',iii
6511 cd          do kkk=1,5
6512 cd            write (2,*) 'kkk=',kkk
6513 cd            do jjj=1,2
6514 cd              write (2,'(3(2f10.5),5x)')
6515 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6516 cd            enddo
6517 cd          enddo
6518 cd        enddo
6519 cd        endif
6520         call transpose2(EUgder(1,1,k),auxmat(1,1))
6521         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6522         call transpose2(EUg(1,1,k),auxmat(1,1))
6523         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6524         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6525         do iii=1,2
6526           do kkk=1,5
6527             do lll=1,3
6528               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6529      &          EAEAderx(1,1,lll,kkk,iii,1))
6530             enddo
6531           enddo
6532         enddo
6533 C A1T kernel(i+1) A2
6534         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6535      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6536      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6537 C Following matrices are needed only for 6-th order cumulants
6538         IF (wcorr6.gt.0.0d0) THEN
6539         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6540      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6541      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6542         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6543      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6544      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6545      &   ADtEAderx(1,1,1,1,1,2))
6546         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6547      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6548      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6549      &   ADtEA1derx(1,1,1,1,1,2))
6550         ENDIF
6551 C End 6-th order cumulants
6552         call transpose2(EUgder(1,1,l),auxmat(1,1))
6553         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6554         call transpose2(EUg(1,1,l),auxmat(1,1))
6555         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6556         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6557         do iii=1,2
6558           do kkk=1,5
6559             do lll=1,3
6560               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6561      &          EAEAderx(1,1,lll,kkk,iii,2))
6562             enddo
6563           enddo
6564         enddo
6565 C AEAb1 and AEAb2
6566 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6567 C They are needed only when the fifth- or the sixth-order cumulants are
6568 C indluded.
6569         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6570         call transpose2(AEA(1,1,1),auxmat(1,1))
6571         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6572         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6573         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6574         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6575         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6576         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6577         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6578         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6579         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6580         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6581         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6582         call transpose2(AEA(1,1,2),auxmat(1,1))
6583         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6584         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6585         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6586         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6587         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6588         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6589         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6590         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6591         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6592         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6593         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6594 C Calculate the Cartesian derivatives of the vectors.
6595         do iii=1,2
6596           do kkk=1,5
6597             do lll=1,3
6598               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6599               call matvec2(auxmat(1,1),b1(1,iti),
6600      &          AEAb1derx(1,lll,kkk,iii,1,1))
6601               call matvec2(auxmat(1,1),Ub2(1,i),
6602      &          AEAb2derx(1,lll,kkk,iii,1,1))
6603               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6604      &          AEAb1derx(1,lll,kkk,iii,2,1))
6605               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6606      &          AEAb2derx(1,lll,kkk,iii,2,1))
6607               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6608               call matvec2(auxmat(1,1),b1(1,itj),
6609      &          AEAb1derx(1,lll,kkk,iii,1,2))
6610               call matvec2(auxmat(1,1),Ub2(1,j),
6611      &          AEAb2derx(1,lll,kkk,iii,1,2))
6612               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6613      &          AEAb1derx(1,lll,kkk,iii,2,2))
6614               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6615      &          AEAb2derx(1,lll,kkk,iii,2,2))
6616             enddo
6617           enddo
6618         enddo
6619         ENDIF
6620 C End vectors
6621       else
6622 C Antiparallel orientation of the two CA-CA-CA frames.
6623 c        if (i.gt.1) then
6624         if (i.gt.1 .and. itype(i).le.ntyp) then
6625           iti=itortyp(itype(i))
6626         else
6627           iti=ntortyp+1
6628         endif
6629         itk1=itortyp(itype(k+1))
6630         itl=itortyp(itype(l))
6631         itj=itortyp(itype(j))
6632 c        if (j.lt.nres-1) then
6633         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6634           itj1=itortyp(itype(j+1))
6635         else
6636           itj1=ntortyp+1
6637         endif
6638 C A2 kernel(j-1)T A1T
6639         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6640      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6641      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6642 C Following matrices are needed only for 6-th order cumulants
6643         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6644      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6645         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6646      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6647      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6648         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6649      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6650      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6651      &   ADtEAderx(1,1,1,1,1,1))
6652         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6653      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6654      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6655      &   ADtEA1derx(1,1,1,1,1,1))
6656         ENDIF
6657 C End 6-th order cumulants
6658         call transpose2(EUgder(1,1,k),auxmat(1,1))
6659         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6660         call transpose2(EUg(1,1,k),auxmat(1,1))
6661         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6662         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6663         do iii=1,2
6664           do kkk=1,5
6665             do lll=1,3
6666               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6667      &          EAEAderx(1,1,lll,kkk,iii,1))
6668             enddo
6669           enddo
6670         enddo
6671 C A2T kernel(i+1)T A1
6672         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6673      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6674      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6675 C Following matrices are needed only for 6-th order cumulants
6676         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6677      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6678         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6679      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6680      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6681         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6682      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6683      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6684      &   ADtEAderx(1,1,1,1,1,2))
6685         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6686      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6687      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6688      &   ADtEA1derx(1,1,1,1,1,2))
6689         ENDIF
6690 C End 6-th order cumulants
6691         call transpose2(EUgder(1,1,j),auxmat(1,1))
6692         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6693         call transpose2(EUg(1,1,j),auxmat(1,1))
6694         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6695         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6696         do iii=1,2
6697           do kkk=1,5
6698             do lll=1,3
6699               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6700      &          EAEAderx(1,1,lll,kkk,iii,2))
6701             enddo
6702           enddo
6703         enddo
6704 C AEAb1 and AEAb2
6705 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6706 C They are needed only when the fifth- or the sixth-order cumulants are
6707 C indluded.
6708         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6709      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6710         call transpose2(AEA(1,1,1),auxmat(1,1))
6711         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6712         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6713         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6714         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6715         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6716         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6717         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6718         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6719         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6720         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6721         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6722         call transpose2(AEA(1,1,2),auxmat(1,1))
6723         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6724         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6725         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6726         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6727         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6728         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6729         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6730         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6731         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6732         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6733         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6734 C Calculate the Cartesian derivatives of the vectors.
6735         do iii=1,2
6736           do kkk=1,5
6737             do lll=1,3
6738               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6739               call matvec2(auxmat(1,1),b1(1,iti),
6740      &          AEAb1derx(1,lll,kkk,iii,1,1))
6741               call matvec2(auxmat(1,1),Ub2(1,i),
6742      &          AEAb2derx(1,lll,kkk,iii,1,1))
6743               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6744      &          AEAb1derx(1,lll,kkk,iii,2,1))
6745               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6746      &          AEAb2derx(1,lll,kkk,iii,2,1))
6747               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6748               call matvec2(auxmat(1,1),b1(1,itl),
6749      &          AEAb1derx(1,lll,kkk,iii,1,2))
6750               call matvec2(auxmat(1,1),Ub2(1,l),
6751      &          AEAb2derx(1,lll,kkk,iii,1,2))
6752               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6753      &          AEAb1derx(1,lll,kkk,iii,2,2))
6754               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6755      &          AEAb2derx(1,lll,kkk,iii,2,2))
6756             enddo
6757           enddo
6758         enddo
6759         ENDIF
6760 C End vectors
6761       endif
6762       return
6763       end
6764 C---------------------------------------------------------------------------
6765       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6766      &  KK,KKderg,AKA,AKAderg,AKAderx)
6767       implicit none
6768       integer nderg
6769       logical transp
6770       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6771      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6772      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6773       integer iii,kkk,lll
6774       integer jjj,mmm
6775       logical lprn
6776       common /kutas/ lprn
6777       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6778       do iii=1,nderg
6779         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6780      &    AKAderg(1,1,iii))
6781       enddo
6782 cd      if (lprn) write (2,*) 'In kernel'
6783       do kkk=1,5
6784 cd        if (lprn) write (2,*) 'kkk=',kkk
6785         do lll=1,3
6786           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6787      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6788 cd          if (lprn) then
6789 cd            write (2,*) 'lll=',lll
6790 cd            write (2,*) 'iii=1'
6791 cd            do jjj=1,2
6792 cd              write (2,'(3(2f10.5),5x)')
6793 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6794 cd            enddo
6795 cd          endif
6796           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6797      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6798 cd          if (lprn) then
6799 cd            write (2,*) 'lll=',lll
6800 cd            write (2,*) 'iii=2'
6801 cd            do jjj=1,2
6802 cd              write (2,'(3(2f10.5),5x)')
6803 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6804 cd            enddo
6805 cd          endif
6806         enddo
6807       enddo
6808       return
6809       end
6810 C---------------------------------------------------------------------------
6811       double precision function eello4(i,j,k,l,jj,kk)
6812       implicit real*8 (a-h,o-z)
6813       include 'DIMENSIONS'
6814       include 'sizesclu.dat'
6815       include 'COMMON.IOUNITS'
6816       include 'COMMON.CHAIN'
6817       include 'COMMON.DERIV'
6818       include 'COMMON.INTERACT'
6819       include 'COMMON.CONTACTS'
6820       include 'COMMON.TORSION'
6821       include 'COMMON.VAR'
6822       include 'COMMON.GEO'
6823       double precision pizda(2,2),ggg1(3),ggg2(3)
6824 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6825 cd        eello4=0.0d0
6826 cd        return
6827 cd      endif
6828 cd      print *,'eello4:',i,j,k,l,jj,kk
6829 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6830 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6831 cold      eij=facont_hb(jj,i)
6832 cold      ekl=facont_hb(kk,k)
6833 cold      ekont=eij*ekl
6834       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6835       if (calc_grad) then
6836 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6837       gcorr_loc(k-1)=gcorr_loc(k-1)
6838      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6839       if (l.eq.j+1) then
6840         gcorr_loc(l-1)=gcorr_loc(l-1)
6841      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6842       else
6843         gcorr_loc(j-1)=gcorr_loc(j-1)
6844      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6845       endif
6846       do iii=1,2
6847         do kkk=1,5
6848           do lll=1,3
6849             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6850      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6851 cd            derx(lll,kkk,iii)=0.0d0
6852           enddo
6853         enddo
6854       enddo
6855 cd      gcorr_loc(l-1)=0.0d0
6856 cd      gcorr_loc(j-1)=0.0d0
6857 cd      gcorr_loc(k-1)=0.0d0
6858 cd      eel4=1.0d0
6859 cd      write (iout,*)'Contacts have occurred for peptide groups',
6860 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6861 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6862       if (j.lt.nres-1) then
6863         j1=j+1
6864         j2=j-1
6865       else
6866         j1=j-1
6867         j2=j-2
6868       endif
6869       if (l.lt.nres-1) then
6870         l1=l+1
6871         l2=l-1
6872       else
6873         l1=l-1
6874         l2=l-2
6875       endif
6876       do ll=1,3
6877 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6878         ggg1(ll)=eel4*g_contij(ll,1)
6879         ggg2(ll)=eel4*g_contij(ll,2)
6880         ghalf=0.5d0*ggg1(ll)
6881 cd        ghalf=0.0d0
6882         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6883         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6884         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6885         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6886 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6887         ghalf=0.5d0*ggg2(ll)
6888 cd        ghalf=0.0d0
6889         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6890         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6891         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6892         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6893       enddo
6894 cd      goto 1112
6895       do m=i+1,j-1
6896         do ll=1,3
6897 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6898           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6899         enddo
6900       enddo
6901       do m=k+1,l-1
6902         do ll=1,3
6903 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6904           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6905         enddo
6906       enddo
6907 1112  continue
6908       do m=i+2,j2
6909         do ll=1,3
6910           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6911         enddo
6912       enddo
6913       do m=k+2,l2
6914         do ll=1,3
6915           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6916         enddo
6917       enddo
6918 cd      do iii=1,nres-3
6919 cd        write (2,*) iii,gcorr_loc(iii)
6920 cd      enddo
6921       endif
6922       eello4=ekont*eel4
6923 cd      write (2,*) 'ekont',ekont
6924 cd      write (iout,*) 'eello4',ekont*eel4
6925       return
6926       end
6927 C---------------------------------------------------------------------------
6928       double precision function eello5(i,j,k,l,jj,kk)
6929       implicit real*8 (a-h,o-z)
6930       include 'DIMENSIONS'
6931       include 'sizesclu.dat'
6932       include 'COMMON.IOUNITS'
6933       include 'COMMON.CHAIN'
6934       include 'COMMON.DERIV'
6935       include 'COMMON.INTERACT'
6936       include 'COMMON.CONTACTS'
6937       include 'COMMON.TORSION'
6938       include 'COMMON.VAR'
6939       include 'COMMON.GEO'
6940       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6941       double precision ggg1(3),ggg2(3)
6942 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6943 C                                                                              C
6944 C                            Parallel chains                                   C
6945 C                                                                              C
6946 C          o             o                   o             o                   C
6947 C         /l\           / \             \   / \           / \   /              C
6948 C        /   \         /   \             \ /   \         /   \ /               C
6949 C       j| o |l1       | o |              o| o |         | o |o                C
6950 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6951 C      \i/   \         /   \ /             /   \         /   \                 C
6952 C       o    k1             o                                                  C
6953 C         (I)          (II)                (III)          (IV)                 C
6954 C                                                                              C
6955 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6956 C                                                                              C
6957 C                            Antiparallel chains                               C
6958 C                                                                              C
6959 C          o             o                   o             o                   C
6960 C         /j\           / \             \   / \           / \   /              C
6961 C        /   \         /   \             \ /   \         /   \ /               C
6962 C      j1| o |l        | o |              o| o |         | o |o                C
6963 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6964 C      \i/   \         /   \ /             /   \         /   \                 C
6965 C       o     k1            o                                                  C
6966 C         (I)          (II)                (III)          (IV)                 C
6967 C                                                                              C
6968 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6969 C                                                                              C
6970 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6971 C                                                                              C
6972 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6973 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6974 cd        eello5=0.0d0
6975 cd        return
6976 cd      endif
6977 cd      write (iout,*)
6978 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6979 cd     &   ' and',k,l
6980       itk=itortyp(itype(k))
6981       itl=itortyp(itype(l))
6982       itj=itortyp(itype(j))
6983       eello5_1=0.0d0
6984       eello5_2=0.0d0
6985       eello5_3=0.0d0
6986       eello5_4=0.0d0
6987 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6988 cd     &   eel5_3_num,eel5_4_num)
6989       do iii=1,2
6990         do kkk=1,5
6991           do lll=1,3
6992             derx(lll,kkk,iii)=0.0d0
6993           enddo
6994         enddo
6995       enddo
6996 cd      eij=facont_hb(jj,i)
6997 cd      ekl=facont_hb(kk,k)
6998 cd      ekont=eij*ekl
6999 cd      write (iout,*)'Contacts have occurred for peptide groups',
7000 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7001 cd      goto 1111
7002 C Contribution from the graph I.
7003 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7004 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7005       call transpose2(EUg(1,1,k),auxmat(1,1))
7006       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7007       vv(1)=pizda(1,1)-pizda(2,2)
7008       vv(2)=pizda(1,2)+pizda(2,1)
7009       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7010      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7011       if (calc_grad) then
7012 C Explicit gradient in virtual-dihedral angles.
7013       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7014      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7015      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7016       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7017       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7018       vv(1)=pizda(1,1)-pizda(2,2)
7019       vv(2)=pizda(1,2)+pizda(2,1)
7020       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7021      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7022      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7023       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7024       vv(1)=pizda(1,1)-pizda(2,2)
7025       vv(2)=pizda(1,2)+pizda(2,1)
7026       if (l.eq.j+1) then
7027         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7028      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7029      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7030       else
7031         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7032      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7033      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7034       endif
7035 C Cartesian gradient
7036       do iii=1,2
7037         do kkk=1,5
7038           do lll=1,3
7039             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7040      &        pizda(1,1))
7041             vv(1)=pizda(1,1)-pizda(2,2)
7042             vv(2)=pizda(1,2)+pizda(2,1)
7043             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7044      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7045      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7046           enddo
7047         enddo
7048       enddo
7049 c      goto 1112
7050       endif
7051 c1111  continue
7052 C Contribution from graph II
7053       call transpose2(EE(1,1,itk),auxmat(1,1))
7054       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7055       vv(1)=pizda(1,1)+pizda(2,2)
7056       vv(2)=pizda(2,1)-pizda(1,2)
7057       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7058      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7059       if (calc_grad) then
7060 C Explicit gradient in virtual-dihedral angles.
7061       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7062      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7063       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7064       vv(1)=pizda(1,1)+pizda(2,2)
7065       vv(2)=pizda(2,1)-pizda(1,2)
7066       if (l.eq.j+1) then
7067         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7068      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7069      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7070       else
7071         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7072      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7073      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7074       endif
7075 C Cartesian gradient
7076       do iii=1,2
7077         do kkk=1,5
7078           do lll=1,3
7079             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7080      &        pizda(1,1))
7081             vv(1)=pizda(1,1)+pizda(2,2)
7082             vv(2)=pizda(2,1)-pizda(1,2)
7083             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7084      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7085      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7086           enddo
7087         enddo
7088       enddo
7089 cd      goto 1112
7090       endif
7091 cd1111  continue
7092       if (l.eq.j+1) then
7093 cd        goto 1110
7094 C Parallel orientation
7095 C Contribution from graph III
7096         call transpose2(EUg(1,1,l),auxmat(1,1))
7097         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7098         vv(1)=pizda(1,1)-pizda(2,2)
7099         vv(2)=pizda(1,2)+pizda(2,1)
7100         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7101      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7102         if (calc_grad) then
7103 C Explicit gradient in virtual-dihedral angles.
7104         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7105      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7106      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7107         call matmat2(AEAderg(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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7111      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7112      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7113         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7114         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7115         vv(1)=pizda(1,1)-pizda(2,2)
7116         vv(2)=pizda(1,2)+pizda(2,1)
7117         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7118      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7119      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7120 C Cartesian gradient
7121         do iii=1,2
7122           do kkk=1,5
7123             do lll=1,3
7124               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7125      &          pizda(1,1))
7126               vv(1)=pizda(1,1)-pizda(2,2)
7127               vv(2)=pizda(1,2)+pizda(2,1)
7128               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7129      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7130      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7131             enddo
7132           enddo
7133         enddo
7134 cd        goto 1112
7135         endif
7136 C Contribution from graph IV
7137 cd1110    continue
7138         call transpose2(EE(1,1,itl),auxmat(1,1))
7139         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7140         vv(1)=pizda(1,1)+pizda(2,2)
7141         vv(2)=pizda(2,1)-pizda(1,2)
7142         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7143      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7144         if (calc_grad) then
7145 C Explicit gradient in virtual-dihedral angles.
7146         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7147      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7148         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7149         vv(1)=pizda(1,1)+pizda(2,2)
7150         vv(2)=pizda(2,1)-pizda(1,2)
7151         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7152      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7153      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7154 C Cartesian gradient
7155         do iii=1,2
7156           do kkk=1,5
7157             do lll=1,3
7158               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7159      &          pizda(1,1))
7160               vv(1)=pizda(1,1)+pizda(2,2)
7161               vv(2)=pizda(2,1)-pizda(1,2)
7162               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7163      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7164      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7165             enddo
7166           enddo
7167         enddo
7168         endif
7169       else
7170 C Antiparallel orientation
7171 C Contribution from graph III
7172 c        goto 1110
7173         call transpose2(EUg(1,1,j),auxmat(1,1))
7174         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7175         vv(1)=pizda(1,1)-pizda(2,2)
7176         vv(2)=pizda(1,2)+pizda(2,1)
7177         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7178      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7179         if (calc_grad) then
7180 C Explicit gradient in virtual-dihedral angles.
7181         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7182      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7183      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7184         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7185         vv(1)=pizda(1,1)-pizda(2,2)
7186         vv(2)=pizda(1,2)+pizda(2,1)
7187         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7188      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7189      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7190         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7191         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7192         vv(1)=pizda(1,1)-pizda(2,2)
7193         vv(2)=pizda(1,2)+pizda(2,1)
7194         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7195      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7196      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7197 C Cartesian gradient
7198         do iii=1,2
7199           do kkk=1,5
7200             do lll=1,3
7201               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7202      &          pizda(1,1))
7203               vv(1)=pizda(1,1)-pizda(2,2)
7204               vv(2)=pizda(1,2)+pizda(2,1)
7205               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7206      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7207      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7208             enddo
7209           enddo
7210         enddo
7211 cd        goto 1112
7212         endif
7213 C Contribution from graph IV
7214 1110    continue
7215         call transpose2(EE(1,1,itj),auxmat(1,1))
7216         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7217         vv(1)=pizda(1,1)+pizda(2,2)
7218         vv(2)=pizda(2,1)-pizda(1,2)
7219         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7220      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7221         if (calc_grad) then
7222 C Explicit gradient in virtual-dihedral angles.
7223         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7224      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7225         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7226         vv(1)=pizda(1,1)+pizda(2,2)
7227         vv(2)=pizda(2,1)-pizda(1,2)
7228         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7229      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7230      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7231 C Cartesian gradient
7232         do iii=1,2
7233           do kkk=1,5
7234             do lll=1,3
7235               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7236      &          pizda(1,1))
7237               vv(1)=pizda(1,1)+pizda(2,2)
7238               vv(2)=pizda(2,1)-pizda(1,2)
7239               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7240      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7241      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7242             enddo
7243           enddo
7244         enddo
7245       endif
7246       endif
7247 1112  continue
7248       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7249 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7250 cd        write (2,*) 'ijkl',i,j,k,l
7251 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7252 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7253 cd      endif
7254 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7255 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7256 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7257 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7258       if (calc_grad) then
7259       if (j.lt.nres-1) then
7260         j1=j+1
7261         j2=j-1
7262       else
7263         j1=j-1
7264         j2=j-2
7265       endif
7266       if (l.lt.nres-1) then
7267         l1=l+1
7268         l2=l-1
7269       else
7270         l1=l-1
7271         l2=l-2
7272       endif
7273 cd      eij=1.0d0
7274 cd      ekl=1.0d0
7275 cd      ekont=1.0d0
7276 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7277       do ll=1,3
7278         ggg1(ll)=eel5*g_contij(ll,1)
7279         ggg2(ll)=eel5*g_contij(ll,2)
7280 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7281         ghalf=0.5d0*ggg1(ll)
7282 cd        ghalf=0.0d0
7283         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7284         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7285         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7286         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7287 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7288         ghalf=0.5d0*ggg2(ll)
7289 cd        ghalf=0.0d0
7290         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7291         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7292         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7293         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7294       enddo
7295 cd      goto 1112
7296       do m=i+1,j-1
7297         do ll=1,3
7298 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7299           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7300         enddo
7301       enddo
7302       do m=k+1,l-1
7303         do ll=1,3
7304 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7305           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7306         enddo
7307       enddo
7308 c1112  continue
7309       do m=i+2,j2
7310         do ll=1,3
7311           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7312         enddo
7313       enddo
7314       do m=k+2,l2
7315         do ll=1,3
7316           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7317         enddo
7318       enddo
7319 cd      do iii=1,nres-3
7320 cd        write (2,*) iii,g_corr5_loc(iii)
7321 cd      enddo
7322       endif
7323       eello5=ekont*eel5
7324 cd      write (2,*) 'ekont',ekont
7325 cd      write (iout,*) 'eello5',ekont*eel5
7326       return
7327       end
7328 c--------------------------------------------------------------------------
7329       double precision function eello6(i,j,k,l,jj,kk)
7330       implicit real*8 (a-h,o-z)
7331       include 'DIMENSIONS'
7332       include 'sizesclu.dat'
7333       include 'COMMON.IOUNITS'
7334       include 'COMMON.CHAIN'
7335       include 'COMMON.DERIV'
7336       include 'COMMON.INTERACT'
7337       include 'COMMON.CONTACTS'
7338       include 'COMMON.TORSION'
7339       include 'COMMON.VAR'
7340       include 'COMMON.GEO'
7341       include 'COMMON.FFIELD'
7342       double precision ggg1(3),ggg2(3)
7343 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7344 cd        eello6=0.0d0
7345 cd        return
7346 cd      endif
7347 cd      write (iout,*)
7348 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7349 cd     &   ' and',k,l
7350       eello6_1=0.0d0
7351       eello6_2=0.0d0
7352       eello6_3=0.0d0
7353       eello6_4=0.0d0
7354       eello6_5=0.0d0
7355       eello6_6=0.0d0
7356 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7357 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7358       do iii=1,2
7359         do kkk=1,5
7360           do lll=1,3
7361             derx(lll,kkk,iii)=0.0d0
7362           enddo
7363         enddo
7364       enddo
7365 cd      eij=facont_hb(jj,i)
7366 cd      ekl=facont_hb(kk,k)
7367 cd      ekont=eij*ekl
7368 cd      eij=1.0d0
7369 cd      ekl=1.0d0
7370 cd      ekont=1.0d0
7371       if (l.eq.j+1) then
7372         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7373         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7374         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7375         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7376         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7377         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7378       else
7379         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7380         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7381         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7382         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7383         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7384           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7385         else
7386           eello6_5=0.0d0
7387         endif
7388         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7389       endif
7390 C If turn contributions are considered, they will be handled separately.
7391       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7392 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7393 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7394 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7395 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7396 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7397 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7398 cd      goto 1112
7399       if (calc_grad) then
7400       if (j.lt.nres-1) then
7401         j1=j+1
7402         j2=j-1
7403       else
7404         j1=j-1
7405         j2=j-2
7406       endif
7407       if (l.lt.nres-1) then
7408         l1=l+1
7409         l2=l-1
7410       else
7411         l1=l-1
7412         l2=l-2
7413       endif
7414       do ll=1,3
7415         ggg1(ll)=eel6*g_contij(ll,1)
7416         ggg2(ll)=eel6*g_contij(ll,2)
7417 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7418         ghalf=0.5d0*ggg1(ll)
7419 cd        ghalf=0.0d0
7420         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7421         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7422         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7423         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7424         ghalf=0.5d0*ggg2(ll)
7425 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7426 cd        ghalf=0.0d0
7427         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7428         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7429         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7430         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7431       enddo
7432 cd      goto 1112
7433       do m=i+1,j-1
7434         do ll=1,3
7435 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7436           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7437         enddo
7438       enddo
7439       do m=k+1,l-1
7440         do ll=1,3
7441 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7442           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7443         enddo
7444       enddo
7445 1112  continue
7446       do m=i+2,j2
7447         do ll=1,3
7448           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7449         enddo
7450       enddo
7451       do m=k+2,l2
7452         do ll=1,3
7453           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7454         enddo
7455       enddo
7456 cd      do iii=1,nres-3
7457 cd        write (2,*) iii,g_corr6_loc(iii)
7458 cd      enddo
7459       endif
7460       eello6=ekont*eel6
7461 cd      write (2,*) 'ekont',ekont
7462 cd      write (iout,*) 'eello6',ekont*eel6
7463       return
7464       end
7465 c--------------------------------------------------------------------------
7466       double precision function eello6_graph1(i,j,k,l,imat,swap)
7467       implicit real*8 (a-h,o-z)
7468       include 'DIMENSIONS'
7469       include 'sizesclu.dat'
7470       include 'COMMON.IOUNITS'
7471       include 'COMMON.CHAIN'
7472       include 'COMMON.DERIV'
7473       include 'COMMON.INTERACT'
7474       include 'COMMON.CONTACTS'
7475       include 'COMMON.TORSION'
7476       include 'COMMON.VAR'
7477       include 'COMMON.GEO'
7478       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7479       logical swap
7480       logical lprn
7481       common /kutas/ lprn
7482 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7483 C                                                                              C
7484 C      Parallel       Antiparallel                                             C
7485 C                                                                              C
7486 C          o             o                                                     C
7487 C         /l\           /j\                                                    C
7488 C        /   \         /   \                                                   C
7489 C       /| o |         | o |\                                                  C
7490 C     \ j|/k\|  /   \  |/k\|l /                                                C
7491 C      \ /   \ /     \ /   \ /                                                 C
7492 C       o     o       o     o                                                  C
7493 C       i             i                                                        C
7494 C                                                                              C
7495 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7496       itk=itortyp(itype(k))
7497       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7498       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7499       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7500       call transpose2(EUgC(1,1,k),auxmat(1,1))
7501       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7502       vv1(1)=pizda1(1,1)-pizda1(2,2)
7503       vv1(2)=pizda1(1,2)+pizda1(2,1)
7504       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7505       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7506       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7507       s5=scalar2(vv(1),Dtobr2(1,i))
7508 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7509       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7510       if (.not. calc_grad) return
7511       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7512      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7513      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7514      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7515      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7516      & +scalar2(vv(1),Dtobr2der(1,i)))
7517       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7518       vv1(1)=pizda1(1,1)-pizda1(2,2)
7519       vv1(2)=pizda1(1,2)+pizda1(2,1)
7520       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7521       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7522       if (l.eq.j+1) then
7523         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7524      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7525      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7526      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7527      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7528       else
7529         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7530      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7531      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7532      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7533      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7534       endif
7535       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7536       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7537       vv1(1)=pizda1(1,1)-pizda1(2,2)
7538       vv1(2)=pizda1(1,2)+pizda1(2,1)
7539       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7540      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7541      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7542      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7543       do iii=1,2
7544         if (swap) then
7545           ind=3-iii
7546         else
7547           ind=iii
7548         endif
7549         do kkk=1,5
7550           do lll=1,3
7551             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7552             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7553             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7554             call transpose2(EUgC(1,1,k),auxmat(1,1))
7555             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7556      &        pizda1(1,1))
7557             vv1(1)=pizda1(1,1)-pizda1(2,2)
7558             vv1(2)=pizda1(1,2)+pizda1(2,1)
7559             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7560             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7561      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7562             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7563      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7564             s5=scalar2(vv(1),Dtobr2(1,i))
7565             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7566           enddo
7567         enddo
7568       enddo
7569       return
7570       end
7571 c----------------------------------------------------------------------------
7572       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7573       implicit real*8 (a-h,o-z)
7574       include 'DIMENSIONS'
7575       include 'sizesclu.dat'
7576       include 'COMMON.IOUNITS'
7577       include 'COMMON.CHAIN'
7578       include 'COMMON.DERIV'
7579       include 'COMMON.INTERACT'
7580       include 'COMMON.CONTACTS'
7581       include 'COMMON.TORSION'
7582       include 'COMMON.VAR'
7583       include 'COMMON.GEO'
7584       logical swap
7585       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7586      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7587       logical lprn
7588       common /kutas/ lprn
7589 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7590 C                                                                              C
7591 C      Parallel       Antiparallel                                             C
7592 C                                                                              C
7593 C          o             o                                                     C
7594 C     \   /l\           /j\   /                                                C
7595 C      \ /   \         /   \ /                                                 C
7596 C       o| o |         | o |o                                                  C
7597 C     \ j|/k\|      \  |/k\|l                                                  C
7598 C      \ /   \       \ /   \                                                   C
7599 C       o             o                                                        C
7600 C       i             i                                                        C
7601 C                                                                              C
7602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7603 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7604 C AL 7/4/01 s1 would occur in the sixth-order moment,
7605 C           but not in a cluster cumulant
7606 #ifdef MOMENT
7607       s1=dip(1,jj,i)*dip(1,kk,k)
7608 #endif
7609       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7610       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7611       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7612       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7613       call transpose2(EUg(1,1,k),auxmat(1,1))
7614       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7615       vv(1)=pizda(1,1)-pizda(2,2)
7616       vv(2)=pizda(1,2)+pizda(2,1)
7617       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7618 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7619 #ifdef MOMENT
7620       eello6_graph2=-(s1+s2+s3+s4)
7621 #else
7622       eello6_graph2=-(s2+s3+s4)
7623 #endif
7624 c      eello6_graph2=-s3
7625       if (.not. calc_grad) return
7626 C Derivatives in gamma(i-1)
7627       if (i.gt.1) then
7628 #ifdef MOMENT
7629         s1=dipderg(1,jj,i)*dip(1,kk,k)
7630 #endif
7631         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7632         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7633         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7634         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7635 #ifdef MOMENT
7636         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7637 #else
7638         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7639 #endif
7640 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7641       endif
7642 C Derivatives in gamma(k-1)
7643 #ifdef MOMENT
7644       s1=dip(1,jj,i)*dipderg(1,kk,k)
7645 #endif
7646       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7647       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7648       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7649       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7650       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7651       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7652       vv(1)=pizda(1,1)-pizda(2,2)
7653       vv(2)=pizda(1,2)+pizda(2,1)
7654       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7655 #ifdef MOMENT
7656       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7657 #else
7658       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7659 #endif
7660 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7661 C Derivatives in gamma(j-1) or gamma(l-1)
7662       if (j.gt.1) then
7663 #ifdef MOMENT
7664         s1=dipderg(3,jj,i)*dip(1,kk,k)
7665 #endif
7666         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7667         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7668         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7669         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7670         vv(1)=pizda(1,1)-pizda(2,2)
7671         vv(2)=pizda(1,2)+pizda(2,1)
7672         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7673 #ifdef MOMENT
7674         if (swap) then
7675           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7676         else
7677           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7678         endif
7679 #endif
7680         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7681 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7682       endif
7683 C Derivatives in gamma(l-1) or gamma(j-1)
7684       if (l.gt.1) then
7685 #ifdef MOMENT
7686         s1=dip(1,jj,i)*dipderg(3,kk,k)
7687 #endif
7688         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7689         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7690         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7691         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7692         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7693         vv(1)=pizda(1,1)-pizda(2,2)
7694         vv(2)=pizda(1,2)+pizda(2,1)
7695         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7696 #ifdef MOMENT
7697         if (swap) then
7698           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7699         else
7700           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7701         endif
7702 #endif
7703         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7704 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7705       endif
7706 C Cartesian derivatives.
7707       if (lprn) then
7708         write (2,*) 'In eello6_graph2'
7709         do iii=1,2
7710           write (2,*) 'iii=',iii
7711           do kkk=1,5
7712             write (2,*) 'kkk=',kkk
7713             do jjj=1,2
7714               write (2,'(3(2f10.5),5x)')
7715      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7716             enddo
7717           enddo
7718         enddo
7719       endif
7720       do iii=1,2
7721         do kkk=1,5
7722           do lll=1,3
7723 #ifdef MOMENT
7724             if (iii.eq.1) then
7725               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7726             else
7727               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7728             endif
7729 #endif
7730             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7731      &        auxvec(1))
7732             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7733             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7734      &        auxvec(1))
7735             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7736             call transpose2(EUg(1,1,k),auxmat(1,1))
7737             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7738      &        pizda(1,1))
7739             vv(1)=pizda(1,1)-pizda(2,2)
7740             vv(2)=pizda(1,2)+pizda(2,1)
7741             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7742 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7743 #ifdef MOMENT
7744             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7745 #else
7746             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7747 #endif
7748             if (swap) then
7749               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7750             else
7751               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7752             endif
7753           enddo
7754         enddo
7755       enddo
7756       return
7757       end
7758 c----------------------------------------------------------------------------
7759       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7760       implicit real*8 (a-h,o-z)
7761       include 'DIMENSIONS'
7762       include 'sizesclu.dat'
7763       include 'COMMON.IOUNITS'
7764       include 'COMMON.CHAIN'
7765       include 'COMMON.DERIV'
7766       include 'COMMON.INTERACT'
7767       include 'COMMON.CONTACTS'
7768       include 'COMMON.TORSION'
7769       include 'COMMON.VAR'
7770       include 'COMMON.GEO'
7771       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7772       logical swap
7773 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7774 C                                                                              C
7775 C      Parallel       Antiparallel                                             C
7776 C                                                                              C
7777 C          o             o                                                     C
7778 C         /l\   /   \   /j\                                                    C
7779 C        /   \ /     \ /   \                                                   C
7780 C       /| o |o       o| o |\                                                  C
7781 C       j|/k\|  /      |/k\|l /                                                C
7782 C        /   \ /       /   \ /                                                 C
7783 C       /     o       /     o                                                  C
7784 C       i             i                                                        C
7785 C                                                                              C
7786 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7787 C
7788 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7789 C           energy moment and not to the cluster cumulant.
7790       iti=itortyp(itype(i))
7791 c      if (j.lt.nres-1) then
7792       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7793         itj1=itortyp(itype(j+1))
7794       else
7795         itj1=ntortyp+1
7796       endif
7797       itk=itortyp(itype(k))
7798       itk1=itortyp(itype(k+1))
7799 c      if (l.lt.nres-1) then
7800       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7801         itl1=itortyp(itype(l+1))
7802       else
7803         itl1=ntortyp+1
7804       endif
7805 #ifdef MOMENT
7806       s1=dip(4,jj,i)*dip(4,kk,k)
7807 #endif
7808       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7809       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7810       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7811       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7812       call transpose2(EE(1,1,itk),auxmat(1,1))
7813       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7814       vv(1)=pizda(1,1)+pizda(2,2)
7815       vv(2)=pizda(2,1)-pizda(1,2)
7816       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7817 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7818 #ifdef MOMENT
7819       eello6_graph3=-(s1+s2+s3+s4)
7820 #else
7821       eello6_graph3=-(s2+s3+s4)
7822 #endif
7823 c      eello6_graph3=-s4
7824       if (.not. calc_grad) return
7825 C Derivatives in gamma(k-1)
7826       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7827       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7828       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7829       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7830 C Derivatives in gamma(l-1)
7831       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7832       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7833       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7834       vv(1)=pizda(1,1)+pizda(2,2)
7835       vv(2)=pizda(2,1)-pizda(1,2)
7836       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7837       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7838 C Cartesian derivatives.
7839       do iii=1,2
7840         do kkk=1,5
7841           do lll=1,3
7842 #ifdef MOMENT
7843             if (iii.eq.1) then
7844               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7845             else
7846               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7847             endif
7848 #endif
7849             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7850      &        auxvec(1))
7851             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7852             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7853      &        auxvec(1))
7854             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7855             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7856      &        pizda(1,1))
7857             vv(1)=pizda(1,1)+pizda(2,2)
7858             vv(2)=pizda(2,1)-pizda(1,2)
7859             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7860 #ifdef MOMENT
7861             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7862 #else
7863             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7864 #endif
7865             if (swap) then
7866               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7867             else
7868               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7869             endif
7870 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7871           enddo
7872         enddo
7873       enddo
7874       return
7875       end
7876 c----------------------------------------------------------------------------
7877       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7878       implicit real*8 (a-h,o-z)
7879       include 'DIMENSIONS'
7880       include 'sizesclu.dat'
7881       include 'COMMON.IOUNITS'
7882       include 'COMMON.CHAIN'
7883       include 'COMMON.DERIV'
7884       include 'COMMON.INTERACT'
7885       include 'COMMON.CONTACTS'
7886       include 'COMMON.TORSION'
7887       include 'COMMON.VAR'
7888       include 'COMMON.GEO'
7889       include 'COMMON.FFIELD'
7890       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7891      & auxvec1(2),auxmat1(2,2)
7892       logical swap
7893 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7894 C                                                                              C
7895 C      Parallel       Antiparallel                                             C
7896 C                                                                              C
7897 C          o             o                                                     C
7898 C         /l\   /   \   /j\                                                    C
7899 C        /   \ /     \ /   \                                                   C
7900 C       /| o |o       o| o |\                                                  C
7901 C     \ j|/k\|      \  |/k\|l                                                  C
7902 C      \ /   \       \ /   \                                                   C
7903 C       o     \       o     \                                                  C
7904 C       i             i                                                        C
7905 C                                                                              C
7906 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7907 C
7908 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7909 C           energy moment and not to the cluster cumulant.
7910 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7911       iti=itortyp(itype(i))
7912       itj=itortyp(itype(j))
7913 c      if (j.lt.nres-1) then
7914       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7915         itj1=itortyp(itype(j+1))
7916       else
7917         itj1=ntortyp+1
7918       endif
7919       itk=itortyp(itype(k))
7920 c      if (k.lt.nres-1) then
7921       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7922         itk1=itortyp(itype(k+1))
7923       else
7924         itk1=ntortyp+1
7925       endif
7926       itl=itortyp(itype(l))
7927       if (l.lt.nres-1) then
7928         itl1=itortyp(itype(l+1))
7929       else
7930         itl1=ntortyp+1
7931       endif
7932 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7933 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7934 cd     & ' itl',itl,' itl1',itl1
7935 #ifdef MOMENT
7936       if (imat.eq.1) then
7937         s1=dip(3,jj,i)*dip(3,kk,k)
7938       else
7939         s1=dip(2,jj,j)*dip(2,kk,l)
7940       endif
7941 #endif
7942       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7943       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7944       if (j.eq.l+1) then
7945         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7946         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7947       else
7948         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7949         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7950       endif
7951       call transpose2(EUg(1,1,k),auxmat(1,1))
7952       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7953       vv(1)=pizda(1,1)-pizda(2,2)
7954       vv(2)=pizda(2,1)+pizda(1,2)
7955       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7956 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7957 #ifdef MOMENT
7958       eello6_graph4=-(s1+s2+s3+s4)
7959 #else
7960       eello6_graph4=-(s2+s3+s4)
7961 #endif
7962       if (.not. calc_grad) return
7963 C Derivatives in gamma(i-1)
7964       if (i.gt.1) then
7965 #ifdef MOMENT
7966         if (imat.eq.1) then
7967           s1=dipderg(2,jj,i)*dip(3,kk,k)
7968         else
7969           s1=dipderg(4,jj,j)*dip(2,kk,l)
7970         endif
7971 #endif
7972         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7973         if (j.eq.l+1) then
7974           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7975           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7976         else
7977           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7978           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7979         endif
7980         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7981         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7982 cd          write (2,*) 'turn6 derivatives'
7983 #ifdef MOMENT
7984           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7985 #else
7986           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7987 #endif
7988         else
7989 #ifdef MOMENT
7990           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7991 #else
7992           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7993 #endif
7994         endif
7995       endif
7996 C Derivatives in gamma(k-1)
7997 #ifdef MOMENT
7998       if (imat.eq.1) then
7999         s1=dip(3,jj,i)*dipderg(2,kk,k)
8000       else
8001         s1=dip(2,jj,j)*dipderg(4,kk,l)
8002       endif
8003 #endif
8004       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8005       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8006       if (j.eq.l+1) then
8007         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8008         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8009       else
8010         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8011         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8012       endif
8013       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8014       call matmat2(AECA(1,1,imat),auxmat1(1,1),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 (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8019 #ifdef MOMENT
8020         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8021 #else
8022         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8023 #endif
8024       else
8025 #ifdef MOMENT
8026         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8027 #else
8028         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8029 #endif
8030       endif
8031 C Derivatives in gamma(j-1) or gamma(l-1)
8032       if (l.eq.j+1 .and. l.gt.1) then
8033         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8034         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8035         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8036         vv(1)=pizda(1,1)-pizda(2,2)
8037         vv(2)=pizda(2,1)+pizda(1,2)
8038         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8039         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8040       else if (j.gt.1) then
8041         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8042         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8043         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8044         vv(1)=pizda(1,1)-pizda(2,2)
8045         vv(2)=pizda(2,1)+pizda(1,2)
8046         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8047         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8048           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8049         else
8050           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8051         endif
8052       endif
8053 C Cartesian derivatives.
8054       do iii=1,2
8055         do kkk=1,5
8056           do lll=1,3
8057 #ifdef MOMENT
8058             if (iii.eq.1) then
8059               if (imat.eq.1) then
8060                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8061               else
8062                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8063               endif
8064             else
8065               if (imat.eq.1) then
8066                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8067               else
8068                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8069               endif
8070             endif
8071 #endif
8072             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8073      &        auxvec(1))
8074             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8075             if (j.eq.l+1) then
8076               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8077      &          b1(1,itj1),auxvec(1))
8078               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8079             else
8080               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8081      &          b1(1,itl1),auxvec(1))
8082               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8083             endif
8084             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8085      &        pizda(1,1))
8086             vv(1)=pizda(1,1)-pizda(2,2)
8087             vv(2)=pizda(2,1)+pizda(1,2)
8088             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8089             if (swap) then
8090               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8091 #ifdef MOMENT
8092                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8093      &             -(s1+s2+s4)
8094 #else
8095                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8096      &             -(s2+s4)
8097 #endif
8098                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8099               else
8100 #ifdef MOMENT
8101                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8102 #else
8103                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8104 #endif
8105                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8106               endif
8107             else
8108 #ifdef MOMENT
8109               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8110 #else
8111               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8112 #endif
8113               if (l.eq.j+1) then
8114                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8115               else
8116                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8117               endif
8118             endif
8119           enddo
8120         enddo
8121       enddo
8122       return
8123       end
8124 c----------------------------------------------------------------------------
8125       double precision function eello_turn6(i,jj,kk)
8126       implicit real*8 (a-h,o-z)
8127       include 'DIMENSIONS'
8128       include 'sizesclu.dat'
8129       include 'COMMON.IOUNITS'
8130       include 'COMMON.CHAIN'
8131       include 'COMMON.DERIV'
8132       include 'COMMON.INTERACT'
8133       include 'COMMON.CONTACTS'
8134       include 'COMMON.TORSION'
8135       include 'COMMON.VAR'
8136       include 'COMMON.GEO'
8137       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8138      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8139      &  ggg1(3),ggg2(3)
8140       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8141      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8142 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8143 C           the respective energy moment and not to the cluster cumulant.
8144       eello_turn6=0.0d0
8145       j=i+4
8146       k=i+1
8147       l=i+3
8148       iti=itortyp(itype(i))
8149       itk=itortyp(itype(k))
8150       itk1=itortyp(itype(k+1))
8151       itl=itortyp(itype(l))
8152       itj=itortyp(itype(j))
8153 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8154 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8155 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8156 cd        eello6=0.0d0
8157 cd        return
8158 cd      endif
8159 cd      write (iout,*)
8160 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8161 cd     &   ' and',k,l
8162 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8163       do iii=1,2
8164         do kkk=1,5
8165           do lll=1,3
8166             derx_turn(lll,kkk,iii)=0.0d0
8167           enddo
8168         enddo
8169       enddo
8170 cd      eij=1.0d0
8171 cd      ekl=1.0d0
8172 cd      ekont=1.0d0
8173       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8174 cd      eello6_5=0.0d0
8175 cd      write (2,*) 'eello6_5',eello6_5
8176 #ifdef MOMENT
8177       call transpose2(AEA(1,1,1),auxmat(1,1))
8178       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8179       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8180       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8181 #else
8182       s1 = 0.0d0
8183 #endif
8184       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8185       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8186       s2 = scalar2(b1(1,itk),vtemp1(1))
8187 #ifdef MOMENT
8188       call transpose2(AEA(1,1,2),atemp(1,1))
8189       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8190       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8191       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8192 #else
8193       s8=0.0d0
8194 #endif
8195       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8196       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8197       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8198 #ifdef MOMENT
8199       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8200       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8201       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8202       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8203       ss13 = scalar2(b1(1,itk),vtemp4(1))
8204       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8205 #else
8206       s13=0.0d0
8207 #endif
8208 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8209 c      s1=0.0d0
8210 c      s2=0.0d0
8211 c      s8=0.0d0
8212 c      s12=0.0d0
8213 c      s13=0.0d0
8214       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8215       if (calc_grad) then
8216 C Derivatives in gamma(i+2)
8217 #ifdef MOMENT
8218       call transpose2(AEA(1,1,1),auxmatd(1,1))
8219       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8220       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8221       call transpose2(AEAderg(1,1,2),atempd(1,1))
8222       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8223       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8224 #else
8225       s8d=0.0d0
8226 #endif
8227       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8228       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8229       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8230 c      s1d=0.0d0
8231 c      s2d=0.0d0
8232 c      s8d=0.0d0
8233 c      s12d=0.0d0
8234 c      s13d=0.0d0
8235       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8236 C Derivatives in gamma(i+3)
8237 #ifdef MOMENT
8238       call transpose2(AEA(1,1,1),auxmatd(1,1))
8239       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8240       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8241       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8242 #else
8243       s1d=0.0d0
8244 #endif
8245       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8246       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8247       s2d = scalar2(b1(1,itk),vtemp1d(1))
8248 #ifdef MOMENT
8249       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8250       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8251 #endif
8252       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8253 #ifdef MOMENT
8254       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8255       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8256       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8257 #else
8258       s13d=0.0d0
8259 #endif
8260 c      s1d=0.0d0
8261 c      s2d=0.0d0
8262 c      s8d=0.0d0
8263 c      s12d=0.0d0
8264 c      s13d=0.0d0
8265 #ifdef MOMENT
8266       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8267      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8268 #else
8269       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8270      &               -0.5d0*ekont*(s2d+s12d)
8271 #endif
8272 C Derivatives in gamma(i+4)
8273       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8274       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8275       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8276 #ifdef MOMENT
8277       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8278       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8279       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8280 #else
8281       s13d = 0.0d0
8282 #endif
8283 c      s1d=0.0d0
8284 c      s2d=0.0d0
8285 c      s8d=0.0d0
8286 C      s12d=0.0d0
8287 c      s13d=0.0d0
8288 #ifdef MOMENT
8289       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8290 #else
8291       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8292 #endif
8293 C Derivatives in gamma(i+5)
8294 #ifdef MOMENT
8295       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8296       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8297       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8298 #else
8299       s1d = 0.0d0
8300 #endif
8301       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8302       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8303       s2d = scalar2(b1(1,itk),vtemp1d(1))
8304 #ifdef MOMENT
8305       call transpose2(AEA(1,1,2),atempd(1,1))
8306       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8307       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8308 #else
8309       s8d = 0.0d0
8310 #endif
8311       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8312       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8313 #ifdef MOMENT
8314       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8315       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8316       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8317 #else
8318       s13d = 0.0d0
8319 #endif
8320 c      s1d=0.0d0
8321 c      s2d=0.0d0
8322 c      s8d=0.0d0
8323 c      s12d=0.0d0
8324 c      s13d=0.0d0
8325 #ifdef MOMENT
8326       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8327      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8328 #else
8329       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8330      &               -0.5d0*ekont*(s2d+s12d)
8331 #endif
8332 C Cartesian derivatives
8333       do iii=1,2
8334         do kkk=1,5
8335           do lll=1,3
8336 #ifdef MOMENT
8337             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8338             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8339             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8340 #else
8341             s1d = 0.0d0
8342 #endif
8343             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8344             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8345      &          vtemp1d(1))
8346             s2d = scalar2(b1(1,itk),vtemp1d(1))
8347 #ifdef MOMENT
8348             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8349             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8350             s8d = -(atempd(1,1)+atempd(2,2))*
8351      &           scalar2(cc(1,1,itl),vtemp2(1))
8352 #else
8353             s8d = 0.0d0
8354 #endif
8355             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8356      &           auxmatd(1,1))
8357             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8358             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8359 c      s1d=0.0d0
8360 c      s2d=0.0d0
8361 c      s8d=0.0d0
8362 c      s12d=0.0d0
8363 c      s13d=0.0d0
8364 #ifdef MOMENT
8365             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8366      &        - 0.5d0*(s1d+s2d)
8367 #else
8368             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8369      &        - 0.5d0*s2d
8370 #endif
8371 #ifdef MOMENT
8372             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8373      &        - 0.5d0*(s8d+s12d)
8374 #else
8375             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8376      &        - 0.5d0*s12d
8377 #endif
8378           enddo
8379         enddo
8380       enddo
8381 #ifdef MOMENT
8382       do kkk=1,5
8383         do lll=1,3
8384           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8385      &      achuj_tempd(1,1))
8386           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8387           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8388           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8389           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8390           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8391      &      vtemp4d(1))
8392           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8393           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8394           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8395         enddo
8396       enddo
8397 #endif
8398 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8399 cd     &  16*eel_turn6_num
8400 cd      goto 1112
8401       if (j.lt.nres-1) then
8402         j1=j+1
8403         j2=j-1
8404       else
8405         j1=j-1
8406         j2=j-2
8407       endif
8408       if (l.lt.nres-1) then
8409         l1=l+1
8410         l2=l-1
8411       else
8412         l1=l-1
8413         l2=l-2
8414       endif
8415       do ll=1,3
8416         ggg1(ll)=eel_turn6*g_contij(ll,1)
8417         ggg2(ll)=eel_turn6*g_contij(ll,2)
8418         ghalf=0.5d0*ggg1(ll)
8419 cd        ghalf=0.0d0
8420         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8421      &    +ekont*derx_turn(ll,2,1)
8422         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8423         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8424      &    +ekont*derx_turn(ll,4,1)
8425         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8426         ghalf=0.5d0*ggg2(ll)
8427 cd        ghalf=0.0d0
8428         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8429      &    +ekont*derx_turn(ll,2,2)
8430         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8431         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8432      &    +ekont*derx_turn(ll,4,2)
8433         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8434       enddo
8435 cd      goto 1112
8436       do m=i+1,j-1
8437         do ll=1,3
8438           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8439         enddo
8440       enddo
8441       do m=k+1,l-1
8442         do ll=1,3
8443           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8444         enddo
8445       enddo
8446 1112  continue
8447       do m=i+2,j2
8448         do ll=1,3
8449           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8450         enddo
8451       enddo
8452       do m=k+2,l2
8453         do ll=1,3
8454           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8455         enddo
8456       enddo
8457 cd      do iii=1,nres-3
8458 cd        write (2,*) iii,g_corr6_loc(iii)
8459 cd      enddo
8460       endif
8461       eello_turn6=ekont*eel_turn6
8462 cd      write (2,*) 'ekont',ekont
8463 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8464       return
8465       end
8466 crc-------------------------------------------------
8467       SUBROUTINE MATVEC2(A1,V1,V2)
8468       implicit real*8 (a-h,o-z)
8469       include 'DIMENSIONS'
8470       DIMENSION A1(2,2),V1(2),V2(2)
8471 c      DO 1 I=1,2
8472 c        VI=0.0
8473 c        DO 3 K=1,2
8474 c    3     VI=VI+A1(I,K)*V1(K)
8475 c        Vaux(I)=VI
8476 c    1 CONTINUE
8477
8478       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8479       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8480
8481       v2(1)=vaux1
8482       v2(2)=vaux2
8483       END
8484 C---------------------------------------
8485       SUBROUTINE MATMAT2(A1,A2,A3)
8486       implicit real*8 (a-h,o-z)
8487       include 'DIMENSIONS'
8488       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8489 c      DIMENSION AI3(2,2)
8490 c        DO  J=1,2
8491 c          A3IJ=0.0
8492 c          DO K=1,2
8493 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8494 c          enddo
8495 c          A3(I,J)=A3IJ
8496 c       enddo
8497 c      enddo
8498
8499       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8500       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8501       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8502       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8503
8504       A3(1,1)=AI3_11
8505       A3(2,1)=AI3_21
8506       A3(1,2)=AI3_12
8507       A3(2,2)=AI3_22
8508       END
8509
8510 c-------------------------------------------------------------------------
8511       double precision function scalar2(u,v)
8512       implicit none
8513       double precision u(2),v(2)
8514       double precision sc
8515       integer i
8516       scalar2=u(1)*v(1)+u(2)*v(2)
8517       return
8518       end
8519
8520 C-----------------------------------------------------------------------------
8521
8522       subroutine transpose2(a,at)
8523       implicit none
8524       double precision a(2,2),at(2,2)
8525       at(1,1)=a(1,1)
8526       at(1,2)=a(2,1)
8527       at(2,1)=a(1,2)
8528       at(2,2)=a(2,2)
8529       return
8530       end
8531 c--------------------------------------------------------------------------
8532       subroutine transpose(n,a,at)
8533       implicit none
8534       integer n,i,j
8535       double precision a(n,n),at(n,n)
8536       do i=1,n
8537         do j=1,n
8538           at(j,i)=a(i,j)
8539         enddo
8540       enddo
8541       return
8542       end
8543 C---------------------------------------------------------------------------
8544       subroutine prodmat3(a1,a2,kk,transp,prod)
8545       implicit none
8546       integer i,j
8547       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8548       logical transp
8549 crc      double precision auxmat(2,2),prod_(2,2)
8550
8551       if (transp) then
8552 crc        call transpose2(kk(1,1),auxmat(1,1))
8553 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8554 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8555
8556            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8557      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8558            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8559      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8560            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8561      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8562            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8563      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8564
8565       else
8566 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8567 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8568
8569            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8570      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8571            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8572      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8573            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8574      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8575            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8576      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8577
8578       endif
8579 c      call transpose2(a2(1,1),a2t(1,1))
8580
8581 crc      print *,transp
8582 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8583 crc      print *,((prod(i,j),i=1,2),j=1,2)
8584
8585       return
8586       end
8587 C-----------------------------------------------------------------------------
8588       double precision function scalar(u,v)
8589       implicit none
8590       double precision u(3),v(3)
8591       double precision sc
8592       integer i
8593       sc=0.0d0
8594       do i=1,3
8595         sc=sc+u(i)*v(i)
8596       enddo
8597       scalar=sc
8598       return
8599       end
8600 C-----------------------------------------------------------------------
8601       double precision function sscale(r)
8602       double precision r,gamm
8603       include "COMMON.SPLITELE"
8604       if(r.lt.r_cut-rlamb) then
8605         sscale=1.0d0
8606       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8607         gamm=(r-(r_cut-rlamb))/rlamb
8608         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8609       else
8610         sscale=0d0
8611       endif
8612       return
8613       end
8614 C-----------------------------------------------------------------------
8615 C-----------------------------------------------------------------------
8616       double precision function sscagrad(r)
8617       double precision r,gamm
8618       include "COMMON.SPLITELE"
8619       if(r.lt.r_cut-rlamb) then
8620         sscagrad=0.0d0
8621       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8622         gamm=(r-(r_cut-rlamb))/rlamb
8623         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8624       else
8625         sscagrad=0.0d0
8626       endif
8627       return
8628       end
8629 C-----------------------------------------------------------------------
8630 C first for shielding is setting of function of side-chains
8631        subroutine set_shield_fac2
8632       implicit real*8 (a-h,o-z)
8633       include 'DIMENSIONS'
8634       include 'COMMON.CHAIN'
8635       include 'COMMON.DERIV'
8636       include 'COMMON.IOUNITS'
8637       include 'COMMON.SHIELD'
8638       include 'COMMON.INTERACT'
8639 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8640       double precision div77_81/0.974996043d0/,
8641      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8642
8643 C the vector between center of side_chain and peptide group
8644        double precision pep_side(3),long,side_calf(3),
8645      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8646      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8647 C the line belowe needs to be changed for FGPROC>1
8648       do i=1,nres-1
8649       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8650       ishield_list(i)=0
8651 Cif there two consequtive dummy atoms there is no peptide group between them
8652 C the line below has to be changed for FGPROC>1
8653       VolumeTotal=0.0
8654       do k=1,nres
8655        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8656        dist_pep_side=0.0
8657        dist_side_calf=0.0
8658        do j=1,3
8659 C first lets set vector conecting the ithe side-chain with kth side-chain
8660       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8661 C      pep_side(j)=2.0d0
8662 C and vector conecting the side-chain with its proper calfa
8663       side_calf(j)=c(j,k+nres)-c(j,k)
8664 C      side_calf(j)=2.0d0
8665       pept_group(j)=c(j,i)-c(j,i+1)
8666 C lets have their lenght
8667       dist_pep_side=pep_side(j)**2+dist_pep_side
8668       dist_side_calf=dist_side_calf+side_calf(j)**2
8669       dist_pept_group=dist_pept_group+pept_group(j)**2
8670       enddo
8671        dist_pep_side=dsqrt(dist_pep_side)
8672        dist_pept_group=dsqrt(dist_pept_group)
8673        dist_side_calf=dsqrt(dist_side_calf)
8674       do j=1,3
8675         pep_side_norm(j)=pep_side(j)/dist_pep_side
8676         side_calf_norm(j)=dist_side_calf
8677       enddo
8678 C now sscale fraction
8679        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8680 C       print *,buff_shield,"buff"
8681 C now sscale
8682         if (sh_frac_dist.le.0.0) cycle
8683 C If we reach here it means that this side chain reaches the shielding sphere
8684 C Lets add him to the list for gradient
8685         ishield_list(i)=ishield_list(i)+1
8686 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8687 C this list is essential otherwise problem would be O3
8688         shield_list(ishield_list(i),i)=k
8689 C Lets have the sscale value
8690         if (sh_frac_dist.gt.1.0) then
8691          scale_fac_dist=1.0d0
8692          do j=1,3
8693          sh_frac_dist_grad(j)=0.0d0
8694          enddo
8695         else
8696          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8697      &                   *(2.0d0*sh_frac_dist-3.0d0)
8698          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8699      &                  /dist_pep_side/buff_shield*0.5d0
8700 C remember for the final gradient multiply sh_frac_dist_grad(j)
8701 C for side_chain by factor -2 !
8702          do j=1,3
8703          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8704 C         sh_frac_dist_grad(j)=0.0d0
8705 C         scale_fac_dist=1.0d0
8706 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8707 C     &                    sh_frac_dist_grad(j)
8708          enddo
8709         endif
8710 C this is what is now we have the distance scaling now volume...
8711       short=short_r_sidechain(itype(k))
8712       long=long_r_sidechain(itype(k))
8713       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8714       sinthet=short/dist_pep_side*costhet
8715 C now costhet_grad
8716 C       costhet=0.6d0
8717 C       sinthet=0.8
8718        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8719 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8720 C     &             -short/dist_pep_side**2/costhet)
8721 C       costhet_fac=0.0d0
8722        do j=1,3
8723          costhet_grad(j)=costhet_fac*pep_side(j)
8724        enddo
8725 C remember for the final gradient multiply costhet_grad(j)
8726 C for side_chain by factor -2 !
8727 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8728 C pep_side0pept_group is vector multiplication
8729       pep_side0pept_group=0.0d0
8730       do j=1,3
8731       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8732       enddo
8733       cosalfa=(pep_side0pept_group/
8734      & (dist_pep_side*dist_side_calf))
8735       fac_alfa_sin=1.0d0-cosalfa**2
8736       fac_alfa_sin=dsqrt(fac_alfa_sin)
8737       rkprim=fac_alfa_sin*(long-short)+short
8738 C      rkprim=short
8739
8740 C now costhet_grad
8741        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8742 C       cosphi=0.6
8743        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8744        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8745      &      dist_pep_side**2)
8746 C       sinphi=0.8
8747        do j=1,3
8748          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8749      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8750      &*(long-short)/fac_alfa_sin*cosalfa/
8751      &((dist_pep_side*dist_side_calf))*
8752      &((side_calf(j))-cosalfa*
8753      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8754 C       cosphi_grad_long(j)=0.0d0
8755         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8756      &*(long-short)/fac_alfa_sin*cosalfa
8757      &/((dist_pep_side*dist_side_calf))*
8758      &(pep_side(j)-
8759      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8760 C       cosphi_grad_loc(j)=0.0d0
8761        enddo
8762 C      print *,sinphi,sinthet
8763       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
8764      &                    /VSolvSphere_div
8765 C     &                    *wshield
8766 C now the gradient...
8767       do j=1,3
8768       grad_shield(j,i)=grad_shield(j,i)
8769 C gradient po skalowaniu
8770      &                +(sh_frac_dist_grad(j)*VofOverlap
8771 C  gradient po costhet
8772      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
8773      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8774      &       sinphi/sinthet*costhet*costhet_grad(j)
8775      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8776      & )*wshield
8777 C grad_shield_side is Cbeta sidechain gradient
8778       grad_shield_side(j,ishield_list(i),i)=
8779      &        (sh_frac_dist_grad(j)*-2.0d0
8780      &        *VofOverlap
8781      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8782      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8783      &       sinphi/sinthet*costhet*costhet_grad(j)
8784      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8785      &       )*wshield
8786
8787        grad_shield_loc(j,ishield_list(i),i)=
8788      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8789      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
8790      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
8791      &        ))
8792      &        *wshield
8793       enddo
8794       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8795       enddo
8796       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
8797 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8798       enddo
8799       return
8800       end
8801 C first for shielding is setting of function of side-chains
8802        subroutine set_shield_fac
8803       implicit real*8 (a-h,o-z)
8804       include 'DIMENSIONS'
8805       include 'COMMON.CHAIN'
8806       include 'COMMON.DERIV'
8807       include 'COMMON.IOUNITS'
8808       include 'COMMON.SHIELD'
8809       include 'COMMON.INTERACT'
8810 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8811       double precision div77_81/0.974996043d0/,
8812      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8813
8814 C the vector between center of side_chain and peptide group
8815        double precision pep_side(3),long,side_calf(3),
8816      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8817      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8818 C the line belowe needs to be changed for FGPROC>1
8819       do i=1,nres-1
8820       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8821       ishield_list(i)=0
8822 Cif there two consequtive dummy atoms there is no peptide group between them
8823 C the line below has to be changed for FGPROC>1
8824       VolumeTotal=0.0
8825       do k=1,nres
8826        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8827        dist_pep_side=0.0
8828        dist_side_calf=0.0
8829        do j=1,3
8830 C first lets set vector conecting the ithe side-chain with kth side-chain
8831       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8832 C      pep_side(j)=2.0d0
8833 C and vector conecting the side-chain with its proper calfa
8834       side_calf(j)=c(j,k+nres)-c(j,k)
8835 C      side_calf(j)=2.0d0
8836       pept_group(j)=c(j,i)-c(j,i+1)
8837 C lets have their lenght
8838       dist_pep_side=pep_side(j)**2+dist_pep_side
8839       dist_side_calf=dist_side_calf+side_calf(j)**2
8840       dist_pept_group=dist_pept_group+pept_group(j)**2
8841       enddo
8842        dist_pep_side=dsqrt(dist_pep_side)
8843        dist_pept_group=dsqrt(dist_pept_group)
8844        dist_side_calf=dsqrt(dist_side_calf)
8845       do j=1,3
8846         pep_side_norm(j)=pep_side(j)/dist_pep_side
8847         side_calf_norm(j)=dist_side_calf
8848       enddo
8849 C now sscale fraction
8850        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8851 C       print *,buff_shield,"buff"
8852 C now sscale
8853         if (sh_frac_dist.le.0.0) cycle
8854 C If we reach here it means that this side chain reaches the shielding sphere
8855 C Lets add him to the list for gradient
8856         ishield_list(i)=ishield_list(i)+1
8857 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8858 C this list is essential otherwise problem would be O3
8859         shield_list(ishield_list(i),i)=k
8860 C Lets have the sscale value
8861         if (sh_frac_dist.gt.1.0) then
8862          scale_fac_dist=1.0d0
8863          do j=1,3
8864          sh_frac_dist_grad(j)=0.0d0
8865          enddo
8866         else
8867          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8868      &                   *(2.0*sh_frac_dist-3.0d0)
8869          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8870      &                  /dist_pep_side/buff_shield*0.5
8871 C remember for the final gradient multiply sh_frac_dist_grad(j)
8872 C for side_chain by factor -2 !
8873          do j=1,3
8874          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8875 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8876 C     &                    sh_frac_dist_grad(j)
8877          enddo
8878         endif
8879 C        if ((i.eq.3).and.(k.eq.2)) then
8880 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8881 C     & ,"TU"
8882 C        endif
8883
8884 C this is what is now we have the distance scaling now volume...
8885       short=short_r_sidechain(itype(k))
8886       long=long_r_sidechain(itype(k))
8887       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8888 C now costhet_grad
8889 C       costhet=0.0d0
8890        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8891 C       costhet_fac=0.0d0
8892        do j=1,3
8893          costhet_grad(j)=costhet_fac*pep_side(j)
8894        enddo
8895 C remember for the final gradient multiply costhet_grad(j)
8896 C for side_chain by factor -2 !
8897 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8898 C pep_side0pept_group is vector multiplication
8899       pep_side0pept_group=0.0
8900       do j=1,3
8901       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8902       enddo
8903       cosalfa=(pep_side0pept_group/
8904      & (dist_pep_side*dist_side_calf))
8905       fac_alfa_sin=1.0-cosalfa**2
8906       fac_alfa_sin=dsqrt(fac_alfa_sin)
8907       rkprim=fac_alfa_sin*(long-short)+short
8908 C now costhet_grad
8909        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8910        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8911
8912        do j=1,3
8913          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8914      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8915      &*(long-short)/fac_alfa_sin*cosalfa/
8916      &((dist_pep_side*dist_side_calf))*
8917      &((side_calf(j))-cosalfa*
8918      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8919
8920         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8921      &*(long-short)/fac_alfa_sin*cosalfa
8922      &/((dist_pep_side*dist_side_calf))*
8923      &(pep_side(j)-
8924      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8925        enddo
8926
8927       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8928      &                    /VSolvSphere_div
8929      &                    *wshield
8930 C now the gradient...
8931 C grad_shield is gradient of Calfa for peptide groups
8932 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8933 C     &               costhet,cosphi
8934 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8935 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8936       do j=1,3
8937       grad_shield(j,i)=grad_shield(j,i)
8938 C gradient po skalowaniu
8939      &                +(sh_frac_dist_grad(j)
8940 C  gradient po costhet
8941      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8942      &-scale_fac_dist*(cosphi_grad_long(j))
8943      &/(1.0-cosphi) )*div77_81
8944      &*VofOverlap
8945 C grad_shield_side is Cbeta sidechain gradient
8946       grad_shield_side(j,ishield_list(i),i)=
8947      &        (sh_frac_dist_grad(j)*-2.0d0
8948      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8949      &       +scale_fac_dist*(cosphi_grad_long(j))
8950      &        *2.0d0/(1.0-cosphi))
8951      &        *div77_81*VofOverlap
8952
8953        grad_shield_loc(j,ishield_list(i),i)=
8954      &   scale_fac_dist*cosphi_grad_loc(j)
8955      &        *2.0d0/(1.0-cosphi)
8956      &        *div77_81*VofOverlap
8957       enddo
8958       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8959       enddo
8960       fac_shield(i)=VolumeTotal*div77_81+div4_81
8961 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8962       enddo
8963       return
8964       end
8965 C--------------------------------------------------------------------------
8966 C-----------------------------------------------------------------------
8967       double precision function sscalelip(r)
8968       double precision r,gamm
8969       include "COMMON.SPLITELE"
8970 C      if(r.lt.r_cut-rlamb) then
8971 C        sscale=1.0d0
8972 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8973 C        gamm=(r-(r_cut-rlamb))/rlamb
8974         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8975 C      else
8976 C        sscale=0d0
8977 C      endif
8978       return
8979       end
8980 C-----------------------------------------------------------------------
8981       double precision function sscagradlip(r)
8982       double precision r,gamm
8983       include "COMMON.SPLITELE"
8984 C     if(r.lt.r_cut-rlamb) then
8985 C        sscagrad=0.0d0
8986 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8987 C        gamm=(r-(r_cut-rlamb))/rlamb
8988         sscagradlip=r*(6*r-6.0d0)
8989 C      else
8990 C        sscagrad=0.0d0
8991 C      endif
8992       return
8993       end
8994
8995 C-----------------------------------------------------------------------
8996 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8997       subroutine Eliptransfer(eliptran)
8998       implicit real*8 (a-h,o-z)
8999       include 'DIMENSIONS'
9000       include 'COMMON.GEO'
9001       include 'COMMON.VAR'
9002       include 'COMMON.LOCAL'
9003       include 'COMMON.CHAIN'
9004       include 'COMMON.DERIV'
9005       include 'COMMON.INTERACT'
9006       include 'COMMON.IOUNITS'
9007       include 'COMMON.CALC'
9008       include 'COMMON.CONTROL'
9009       include 'COMMON.SPLITELE'
9010       include 'COMMON.SBRIDGE'
9011 C this is done by Adasko
9012 C      print *,"wchodze"
9013 C structure of box:
9014 C      water
9015 C--bordliptop-- buffore starts
9016 C--bufliptop--- here true lipid starts
9017 C      lipid
9018 C--buflipbot--- lipid ends buffore starts
9019 C--bordlipbot--buffore ends
9020       eliptran=0.0
9021       write(iout,*) "I am in?"
9022       do i=1,nres
9023 C       do i=1,1
9024         if (itype(i).eq.ntyp1) cycle
9025
9026         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9027         if (positi.le.0) positi=positi+boxzsize
9028 C        print *,i
9029 C first for peptide groups
9030 c for each residue check if it is in lipid or lipid water border area
9031        if ((positi.gt.bordlipbot)
9032      &.and.(positi.lt.bordliptop)) then
9033 C the energy transfer exist
9034         if (positi.lt.buflipbot) then
9035 C what fraction I am in
9036          fracinbuf=1.0d0-
9037      &        ((positi-bordlipbot)/lipbufthick)
9038 C lipbufthick is thickenes of lipid buffore
9039          sslip=sscalelip(fracinbuf)
9040          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9041          eliptran=eliptran+sslip*pepliptran
9042          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9043          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9044 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9045         elseif (positi.gt.bufliptop) then
9046          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9047          sslip=sscalelip(fracinbuf)
9048          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9049          eliptran=eliptran+sslip*pepliptran
9050          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9051          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9052 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9053 C          print *, "doing sscalefor top part"
9054 C         print *,i,sslip,fracinbuf,ssgradlip
9055         else
9056          eliptran=eliptran+pepliptran
9057 C         print *,"I am in true lipid"
9058         endif
9059 C       else
9060 C       eliptran=elpitran+0.0 ! I am in water
9061        endif
9062        enddo
9063 C       print *, "nic nie bylo w lipidzie?"
9064 C now multiply all by the peptide group transfer factor
9065 C       eliptran=eliptran*pepliptran
9066 C now the same for side chains
9067 CV       do i=1,1
9068        do i=1,nres
9069         if (itype(i).eq.ntyp1) cycle
9070         positi=(mod(c(3,i+nres),boxzsize))
9071         if (positi.le.0) positi=positi+boxzsize
9072 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9073 c for each residue check if it is in lipid or lipid water border area
9074 C       respos=mod(c(3,i+nres),boxzsize)
9075 C       print *,positi,bordlipbot,buflipbot
9076        if ((positi.gt.bordlipbot)
9077      & .and.(positi.lt.bordliptop)) then
9078 C the energy transfer exist
9079         if (positi.lt.buflipbot) then
9080          fracinbuf=1.0d0-
9081      &     ((positi-bordlipbot)/lipbufthick)
9082 C lipbufthick is thickenes of lipid buffore
9083          sslip=sscalelip(fracinbuf)
9084          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9085          eliptran=eliptran+sslip*liptranene(itype(i))
9086          gliptranx(3,i)=gliptranx(3,i)
9087      &+ssgradlip*liptranene(itype(i))
9088          gliptranc(3,i-1)= gliptranc(3,i-1)
9089      &+ssgradlip*liptranene(itype(i))
9090 C         print *,"doing sccale for lower part"
9091         elseif (positi.gt.bufliptop) then
9092          fracinbuf=1.0d0-
9093      &((bordliptop-positi)/lipbufthick)
9094          sslip=sscalelip(fracinbuf)
9095          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9096          eliptran=eliptran+sslip*liptranene(itype(i))
9097          gliptranx(3,i)=gliptranx(3,i)
9098      &+ssgradlip*liptranene(itype(i))
9099          gliptranc(3,i-1)= gliptranc(3,i-1)
9100      &+ssgradlip*liptranene(itype(i))
9101 C          print *, "doing sscalefor top part",sslip,fracinbuf
9102         else
9103          eliptran=eliptran+liptranene(itype(i))
9104 C         print *,"I am in true lipid"
9105         endif
9106         endif ! if in lipid or buffor
9107 C       else
9108 C       eliptran=elpitran+0.0 ! I am in water
9109        enddo
9110        return
9111        end
9112 C-------------------------------------------------------------------------------------
9113 C-----------------------------------------------------------------------
9114 C-----------------------------------------------------------
9115 C This subroutine is to mimic the histone like structure but as well can be
9116 C utilizet to nanostructures (infinit) small modification has to be used to
9117 C make it finite (z gradient at the ends has to be changes as well as the x,y
9118 C gradient has to be modified at the ends
9119 C The energy function is Kihara potential
9120 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9121 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9122 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9123 C simple Kihara potential
9124       subroutine calctube(Etube)
9125        implicit real*8 (a-h,o-z)
9126       include 'DIMENSIONS'
9127       include 'COMMON.GEO'
9128       include 'COMMON.VAR'
9129       include 'COMMON.LOCAL'
9130       include 'COMMON.CHAIN'
9131       include 'COMMON.DERIV'
9132       include 'COMMON.INTERACT'
9133       include 'COMMON.IOUNITS'
9134       include 'COMMON.CALC'
9135       include 'COMMON.CONTROL'
9136       include 'COMMON.SPLITELE'
9137       include 'COMMON.SBRIDGE'
9138       double precision tub_r,vectube(3),enetube(maxres*2)
9139       Etube=0.0d0
9140       do i=itube_start,itube_end
9141         enetube(i)=0.0d0
9142         enetube(i+nres)=0.0d0
9143       enddo
9144 C first we calculate the distance from tube center
9145 C first sugare-phosphate group for NARES this would be peptide group
9146 C for UNRES
9147        do i=itube_start,itube_end
9148 C lets ommit dummy atoms for now
9149        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9150 C now calculate distance from center of tube and direction vectors
9151       xmin=boxxsize
9152       ymin=boxysize
9153         do j=-1,1
9154          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9155          vectube(1)=vectube(1)+boxxsize*j
9156          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9157          vectube(2)=vectube(2)+boxysize*j
9158
9159          xminact=abs(vectube(1)-tubecenter(1))
9160          yminact=abs(vectube(2)-tubecenter(2))
9161            if (xmin.gt.xminact) then
9162             xmin=xminact
9163             xtemp=vectube(1)
9164            endif
9165            if (ymin.gt.yminact) then
9166              ymin=yminact
9167              ytemp=vectube(2)
9168             endif
9169          enddo
9170       vectube(1)=xtemp
9171       vectube(2)=ytemp
9172       vectube(1)=vectube(1)-tubecenter(1)
9173       vectube(2)=vectube(2)-tubecenter(2)
9174
9175 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9176 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9177
9178 C as the tube is infinity we do not calculate the Z-vector use of Z
9179 C as chosen axis
9180       vectube(3)=0.0d0
9181 C now calculte the distance
9182        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9183 C now normalize vector
9184       vectube(1)=vectube(1)/tub_r
9185       vectube(2)=vectube(2)/tub_r
9186 C calculte rdiffrence between r and r0
9187       rdiff=tub_r-tubeR0
9188 C and its 6 power
9189       rdiff6=rdiff**6.0d0
9190 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9191        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
9192 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9193 C       print *,rdiff,rdiff6,pep_aa_tube
9194 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9195 C now we calculate gradient
9196        fac=(-12.0d0*pep_aa_tube/rdiff6-
9197      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
9198 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9199 C     &rdiff,fac
9200
9201 C now direction of gg_tube vector
9202         do j=1,3
9203         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9204         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9205         enddo
9206         enddo
9207 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
9208 C        print *,gg_tube(1,0),"TU"
9209
9210
9211        do i=itube_start,itube_end
9212 C Lets not jump over memory as we use many times iti
9213          iti=itype(i)
9214 C lets ommit dummy atoms for now
9215          if ((iti.eq.ntyp1)
9216 C in UNRES uncomment the line below as GLY has no side-chain...
9217 C      .or.(iti.eq.10)
9218      &   ) cycle
9219       xmin=boxxsize
9220       ymin=boxysize
9221         do j=-1,1
9222          vectube(1)=mod((c(1,i+nres)),boxxsize)
9223          vectube(1)=vectube(1)+boxxsize*j
9224          vectube(2)=mod((c(2,i+nres)),boxysize)
9225          vectube(2)=vectube(2)+boxysize*j
9226
9227          xminact=abs(vectube(1)-tubecenter(1))
9228          yminact=abs(vectube(2)-tubecenter(2))
9229            if (xmin.gt.xminact) then
9230             xmin=xminact
9231             xtemp=vectube(1)
9232            endif
9233            if (ymin.gt.yminact) then
9234              ymin=yminact
9235              ytemp=vectube(2)
9236             endif
9237          enddo
9238       vectube(1)=xtemp
9239       vectube(2)=ytemp
9240 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
9241 C     &     tubecenter(2)
9242       vectube(1)=vectube(1)-tubecenter(1)
9243       vectube(2)=vectube(2)-tubecenter(2)
9244
9245 C as the tube is infinity we do not calculate the Z-vector use of Z
9246 C as chosen axis
9247       vectube(3)=0.0d0
9248 C now calculte the distance
9249        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9250 C now normalize vector
9251       vectube(1)=vectube(1)/tub_r
9252       vectube(2)=vectube(2)/tub_r
9253
9254 C calculte rdiffrence between r and r0
9255       rdiff=tub_r-tubeR0
9256 C and its 6 power
9257       rdiff6=rdiff**6.0d0
9258 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9259        sc_aa_tube=sc_aa_tube_par(iti)
9260        sc_bb_tube=sc_bb_tube_par(iti)
9261        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
9262 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9263 C now we calculate gradient
9264        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9265      &       6.0d0*sc_bb_tube/rdiff6/rdiff
9266 C now direction of gg_tube vector
9267          do j=1,3
9268           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9269           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9270          enddo
9271         enddo
9272         do i=itube_start,itube_end
9273           Etube=Etube+enetube(i)+enetube(i+nres)
9274         enddo
9275 C        print *,"ETUBE", etube
9276         return
9277         end
9278 C TO DO 1) add to total energy
9279 C       2) add to gradient summation
9280 C       3) add reading parameters (AND of course oppening of PARAM file)
9281 C       4) add reading the center of tube
9282 C       5) add COMMONs
9283 C       6) add to zerograd
9284
9285 C-----------------------------------------------------------------------
9286 C-----------------------------------------------------------
9287 C This subroutine is to mimic the histone like structure but as well can be
9288 C utilizet to nanostructures (infinit) small modification has to be used to
9289 C make it finite (z gradient at the ends has to be changes as well as the x,y
9290 C gradient has to be modified at the ends
9291 C The energy function is Kihara potential
9292 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9293 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9294 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9295 C simple Kihara potential
9296       subroutine calctube2(Etube)
9297        implicit real*8 (a-h,o-z)
9298       include 'DIMENSIONS'
9299       include 'COMMON.GEO'
9300       include 'COMMON.VAR'
9301       include 'COMMON.LOCAL'
9302       include 'COMMON.CHAIN'
9303       include 'COMMON.DERIV'
9304       include 'COMMON.INTERACT'
9305       include 'COMMON.IOUNITS'
9306       include 'COMMON.CALC'
9307       include 'COMMON.CONTROL'
9308       include 'COMMON.SPLITELE'
9309       include 'COMMON.SBRIDGE'
9310       double precision tub_r,vectube(3),enetube(maxres*2)
9311       Etube=0.0d0
9312       do i=itube_start,itube_end
9313         enetube(i)=0.0d0
9314         enetube(i+nres)=0.0d0
9315       enddo
9316 C first we calculate the distance from tube center
9317 C first sugare-phosphate group for NARES this would be peptide group
9318 C for UNRES
9319        do i=itube_start,itube_end
9320 C lets ommit dummy atoms for now
9321
9322        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9323 C now calculate distance from center of tube and direction vectors
9324 C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9325 C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
9326 C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9327 C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
9328       xmin=boxxsize
9329       ymin=boxysize
9330         do j=-1,1
9331          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9332          vectube(1)=vectube(1)+boxxsize*j
9333          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9334          vectube(2)=vectube(2)+boxysize*j
9335
9336          xminact=abs(vectube(1)-tubecenter(1))
9337          yminact=abs(vectube(2)-tubecenter(2))
9338            if (xmin.gt.xminact) then
9339             xmin=xminact
9340             xtemp=vectube(1)
9341            endif
9342            if (ymin.gt.yminact) then
9343              ymin=yminact
9344              ytemp=vectube(2)
9345             endif
9346          enddo
9347       vectube(1)=xtemp
9348       vectube(2)=ytemp
9349       vectube(1)=vectube(1)-tubecenter(1)
9350       vectube(2)=vectube(2)-tubecenter(2)
9351
9352 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9353 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9354
9355 C as the tube is infinity we do not calculate the Z-vector use of Z
9356 C as chosen axis
9357       vectube(3)=0.0d0
9358 C now calculte the distance
9359        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9360 C now normalize vector
9361       vectube(1)=vectube(1)/tub_r
9362       vectube(2)=vectube(2)/tub_r
9363 C calculte rdiffrence between r and r0
9364       rdiff=tub_r-tubeR0
9365 C and its 6 power
9366       rdiff6=rdiff**6.0d0
9367 C THIS FRAGMENT MAKES TUBE FINITE
9368         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
9369         if (positi.le.0) positi=positi+boxzsize
9370 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9371 c for each residue check if it is in lipid or lipid water border area
9372 C       respos=mod(c(3,i+nres),boxzsize)
9373        print *,positi,bordtubebot,buftubebot,bordtubetop
9374        if ((positi.gt.bordtubebot)
9375      & .and.(positi.lt.bordtubetop)) then
9376 C the energy transfer exist
9377         if (positi.lt.buftubebot) then
9378          fracinbuf=1.0d0-
9379      &     ((positi-bordtubebot)/tubebufthick)
9380 C lipbufthick is thickenes of lipid buffore
9381          sstube=sscalelip(fracinbuf)
9382          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
9383          print *,ssgradtube, sstube,tubetranene(itype(i))
9384          enetube(i)=enetube(i)+sstube*tubetranenepep
9385 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9386 C     &+ssgradtube*tubetranene(itype(i))
9387 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9388 C     &+ssgradtube*tubetranene(itype(i))
9389 C         print *,"doing sccale for lower part"
9390         elseif (positi.gt.buftubetop) then
9391          fracinbuf=1.0d0-
9392      &((bordtubetop-positi)/tubebufthick)
9393          sstube=sscalelip(fracinbuf)
9394          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
9395          enetube(i)=enetube(i)+sstube*tubetranenepep
9396 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9397 C     &+ssgradtube*tubetranene(itype(i))
9398 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9399 C     &+ssgradtube*tubetranene(itype(i))
9400 C          print *, "doing sscalefor top part",sslip,fracinbuf
9401         else
9402          sstube=1.0d0
9403          ssgradtube=0.0d0
9404          enetube(i)=enetube(i)+sstube*tubetranenepep
9405 C         print *,"I am in true lipid"
9406         endif
9407         else
9408 C          sstube=0.0d0
9409 C          ssgradtube=0.0d0
9410         cycle
9411         endif ! if in lipid or buffor
9412
9413 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9414        enetube(i)=enetube(i)+sstube*
9415      &(pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
9416 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9417 C       print *,rdiff,rdiff6,pep_aa_tube
9418 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9419 C now we calculate gradient
9420        fac=(-12.0d0*pep_aa_tube/rdiff6-
9421      &       6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
9422 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9423 C     &rdiff,fac
9424
9425 C now direction of gg_tube vector
9426         do j=1,3
9427         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9428         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9429         enddo
9430          gg_tube(3,i)=gg_tube(3,i)
9431      &+ssgradtube*enetube(i)/sstube/2.0d0
9432          gg_tube(3,i-1)= gg_tube(3,i-1)
9433      &+ssgradtube*enetube(i)/sstube/2.0d0
9434
9435         enddo
9436 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
9437 C        print *,gg_tube(1,0),"TU"
9438         do i=itube_start,itube_end
9439 C Lets not jump over memory as we use many times iti
9440          iti=itype(i)
9441 C lets ommit dummy atoms for now
9442          if ((iti.eq.ntyp1)
9443 C in UNRES uncomment the line below as GLY has no side-chain...
9444      &      .or.(iti.eq.10)
9445      &   ) cycle
9446           vectube(1)=c(1,i+nres)
9447           vectube(1)=mod(vectube(1),boxxsize)
9448           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
9449           vectube(2)=c(2,i+nres)
9450           vectube(2)=mod(vectube(2),boxysize)
9451           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
9452
9453       vectube(1)=vectube(1)-tubecenter(1)
9454       vectube(2)=vectube(2)-tubecenter(2)
9455 C THIS FRAGMENT MAKES TUBE FINITE
9456         positi=(mod(c(3,i+nres),boxzsize))
9457         if (positi.le.0) positi=positi+boxzsize
9458 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9459 c for each residue check if it is in lipid or lipid water border area
9460 C       respos=mod(c(3,i+nres),boxzsize)
9461        print *,positi,bordtubebot,buftubebot,bordtubetop
9462        if ((positi.gt.bordtubebot)
9463      & .and.(positi.lt.bordtubetop)) then
9464 C the energy transfer exist
9465         if (positi.lt.buftubebot) then
9466          fracinbuf=1.0d0-
9467      &     ((positi-bordtubebot)/tubebufthick)
9468 C lipbufthick is thickenes of lipid buffore
9469          sstube=sscalelip(fracinbuf)
9470          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
9471          print *,ssgradtube, sstube,tubetranene(itype(i))
9472          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9473 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9474 C     &+ssgradtube*tubetranene(itype(i))
9475 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9476 C     &+ssgradtube*tubetranene(itype(i))
9477 C         print *,"doing sccale for lower part"
9478         elseif (positi.gt.buftubetop) then
9479          fracinbuf=1.0d0-
9480      &((bordtubetop-positi)/tubebufthick)
9481          sstube=sscalelip(fracinbuf)
9482          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
9483          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9484 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9485 C     &+ssgradtube*tubetranene(itype(i))
9486 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9487 C     &+ssgradtube*tubetranene(itype(i))
9488 C          print *, "doing sscalefor top part",sslip,fracinbuf
9489         else
9490          sstube=1.0d0
9491          ssgradtube=0.0d0
9492          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9493 C         print *,"I am in true lipid"
9494         endif
9495         else
9496 C          sstube=0.0d0
9497 C          ssgradtube=0.0d0
9498         cycle
9499         endif ! if in lipid or buffor
9500 CEND OF FINITE FRAGMENT
9501 C as the tube is infinity we do not calculate the Z-vector use of Z
9502 C as chosen axis
9503       vectube(3)=0.0d0
9504 C now calculte the distance
9505        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9506 C now normalize vector
9507       vectube(1)=vectube(1)/tub_r
9508       vectube(2)=vectube(2)/tub_r
9509 C calculte rdiffrence between r and r0
9510       rdiff=tub_r-tubeR0
9511 C and its 6 power
9512       rdiff6=rdiff**6.0d0
9513 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9514        sc_aa_tube=sc_aa_tube_par(iti)
9515        sc_bb_tube=sc_bb_tube_par(iti)
9516        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
9517      &                 *sstube+enetube(i+nres)
9518 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9519 C now we calculate gradient
9520        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9521      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
9522 C now direction of gg_tube vector
9523          do j=1,3
9524           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9525           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9526          enddo
9527          gg_tube_SC(3,i)=gg_tube_SC(3,i)
9528      &+ssgradtube*enetube(i+nres)/sstube
9529          gg_tube(3,i-1)= gg_tube(3,i-1)
9530      &+ssgradtube*enetube(i+nres)/sstube
9531
9532         enddo
9533         do i=itube_start,itube_end
9534           Etube=Etube+enetube(i)+enetube(i+nres)
9535         enddo
9536 C        print *,"ETUBE", etube
9537         return
9538         end
9539 C TO DO 1) add to total energy
9540 C       2) add to gradient summation
9541 C       3) add reading parameters (AND of course oppening of PARAM file)
9542 C       4) add reading the center of tube
9543 C       5) add COMMONs
9544 C       6) add to zerograd
9545
9546
9547 C#-------------------------------------------------------------------------------
9548 C This subroutine is to mimic the histone like structure but as well can be
9549 C utilizet to nanostructures (infinit) small modification has to be used to
9550 C make it finite (z gradient at the ends has to be changes as well as the x,y
9551 C gradient has to be modified at the ends
9552 C The energy function is Kihara potential
9553 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9554 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9555 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9556 C simple Kihara potential
9557       subroutine calcnano(Etube)
9558        implicit real*8 (a-h,o-z)
9559       include 'DIMENSIONS'
9560       include 'COMMON.GEO'
9561       include 'COMMON.VAR'
9562       include 'COMMON.LOCAL'
9563       include 'COMMON.CHAIN'
9564       include 'COMMON.DERIV'
9565       include 'COMMON.INTERACT'
9566       include 'COMMON.IOUNITS'
9567       include 'COMMON.CALC'
9568       include 'COMMON.CONTROL'
9569       include 'COMMON.SPLITELE'
9570       include 'COMMON.SBRIDGE'
9571       double precision tub_r,vectube(3),enetube(maxres*2),
9572      & enecavtube(maxres*2)
9573       Etube=0.0d0
9574       do i=itube_start,itube_end
9575         enetube(i)=0.0d0
9576         enetube(i+nres)=0.0d0
9577       enddo
9578 C first we calculate the distance from tube center
9579 C first sugare-phosphate group for NARES this would be peptide group
9580 C for UNRES
9581        do i=itube_start,itube_end
9582 C lets ommit dummy atoms for now
9583        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9584 C now calculate distance from center of tube and direction vectors
9585       xmin=boxxsize
9586       ymin=boxysize
9587       zmin=boxzsize
9588
9589         do j=-1,1
9590          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9591          vectube(1)=vectube(1)+boxxsize*j
9592          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9593          vectube(2)=vectube(2)+boxysize*j
9594          vectube(3)=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
9595          vectube(3)=vectube(3)+boxzsize*j
9596
9597
9598          xminact=abs(vectube(1)-tubecenter(1))
9599          yminact=abs(vectube(2)-tubecenter(2))
9600          zminact=abs(vectube(3)-tubecenter(3))
9601
9602            if (xmin.gt.xminact) then
9603             xmin=xminact
9604             xtemp=vectube(1)
9605            endif
9606            if (ymin.gt.yminact) then
9607              ymin=yminact
9608              ytemp=vectube(2)
9609             endif
9610            if (zmin.gt.zminact) then
9611              zmin=zminact
9612              ztemp=vectube(3)
9613             endif
9614          enddo
9615       vectube(1)=xtemp
9616       vectube(2)=ytemp
9617       vectube(3)=ztemp
9618
9619       vectube(1)=vectube(1)-tubecenter(1)
9620       vectube(2)=vectube(2)-tubecenter(2)
9621       vectube(3)=vectube(3)-tubecenter(3)
9622
9623 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9624 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9625 C as the tube is infinity we do not calculate the Z-vector use of Z
9626 C as chosen axis
9627 C      vectube(3)=0.0d0
9628 C now calculte the distance
9629        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9630 C now normalize vector
9631       vectube(1)=vectube(1)/tub_r
9632       vectube(2)=vectube(2)/tub_r
9633       vectube(3)=vectube(3)/tub_r
9634 C calculte rdiffrence between r and r0
9635       rdiff=tub_r-tubeR0
9636 C and its 6 power
9637       rdiff6=rdiff**6.0d0
9638 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9639        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
9640 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9641 C       print *,rdiff,rdiff6,pep_aa_tube
9642 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9643 C now we calculate gradient
9644        fac=(-12.0d0*pep_aa_tube/rdiff6-
9645      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
9646 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9647 C     &rdiff,fac
9648          if (acavtubpep.eq.0.0d0) then
9649 C go to 667
9650          enecavtube(i)=0.0
9651          faccav=0.0
9652          else
9653          denominator=(1.0+dcavtubpep*rdiff6*rdiff6)
9654          enecavtube(i)=
9655      &   (bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)+ccavtubpep)
9656      &   /denominator
9657          enecavtube(i)=0.0
9658          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/sqrt(rdiff))
9659      &   *denominator-(bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)
9660      &   +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)
9661      &   /denominator**2.0d0
9662 C         faccav=0.0
9663 C         fac=fac+faccav
9664 C 667     continue
9665          endif
9666 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtubpep,denominator,
9667 C     &   enecavtube(i),faccav
9668 C         print *,"licz=",
9669 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9670 CX         print *,"finene=",enetube(i+nres)+enecavtube(i)
9671
9672 C now direction of gg_tube vector
9673         do j=1,3
9674         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9675         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9676         enddo
9677         enddo
9678
9679        do i=itube_start,itube_end
9680         enecavtube(i)=0.0
9681 C Lets not jump over memory as we use many times iti
9682          iti=itype(i)
9683 C lets ommit dummy atoms for now
9684          if ((iti.eq.ntyp1)
9685 C in UNRES uncomment the line below as GLY has no side-chain...
9686 C      .or.(iti.eq.10)
9687      &   ) cycle
9688       xmin=boxxsize
9689       ymin=boxysize
9690       zmin=boxzsize
9691         do j=-1,1
9692          vectube(1)=mod((c(1,i+nres)),boxxsize)
9693          vectube(1)=vectube(1)+boxxsize*j
9694          vectube(2)=mod((c(2,i+nres)),boxysize)
9695          vectube(2)=vectube(2)+boxysize*j
9696          vectube(3)=mod((c(3,i+nres)),boxzsize)
9697          vectube(3)=vectube(3)+boxzsize*j
9698
9699
9700          xminact=abs(vectube(1)-tubecenter(1))
9701          yminact=abs(vectube(2)-tubecenter(2))
9702          zminact=abs(vectube(3)-tubecenter(3))
9703
9704            if (xmin.gt.xminact) then
9705             xmin=xminact
9706             xtemp=vectube(1)
9707            endif
9708            if (ymin.gt.yminact) then
9709              ymin=yminact
9710              ytemp=vectube(2)
9711             endif
9712            if (zmin.gt.zminact) then
9713              zmin=zminact
9714              ztemp=vectube(3)
9715             endif
9716          enddo
9717       vectube(1)=xtemp
9718       vectube(2)=ytemp
9719       vectube(3)=ztemp
9720
9721 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
9722 C     &     tubecenter(2)
9723       vectube(1)=vectube(1)-tubecenter(1)
9724       vectube(2)=vectube(2)-tubecenter(2)
9725       vectube(3)=vectube(3)-tubecenter(3)
9726 C now calculte the distance
9727        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9728 C now normalize vector
9729       vectube(1)=vectube(1)/tub_r
9730       vectube(2)=vectube(2)/tub_r
9731       vectube(3)=vectube(3)/tub_r
9732
9733 C calculte rdiffrence between r and r0
9734       rdiff=tub_r-tubeR0
9735 C and its 6 power
9736       rdiff6=rdiff**6.0d0
9737 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9738        sc_aa_tube=sc_aa_tube_par(iti)
9739        sc_bb_tube=sc_bb_tube_par(iti)
9740        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
9741 C       enetube(i+nres)=0.0d0
9742 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9743 C now we calculate gradient
9744        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9745      &       6.0d0*sc_bb_tube/rdiff6/rdiff
9746 C       fac=0.0
9747 C now direction of gg_tube vector
9748 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
9749          if (acavtub(iti).eq.0.0d0) then
9750 C go to 667
9751          enecavtube(i+nres)=0.0
9752          faccav=0.0
9753          else
9754          denominator=(1.0+dcavtub(iti)*rdiff6*rdiff6)
9755          enecavtube(i+nres)=
9756      &   (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9757      &   /denominator
9758 C         enecavtube(i)=0.0
9759          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/sqrt(rdiff))
9760      &   *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)
9761      &   +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)
9762      &   /denominator**2.0d0
9763 C         faccav=0.0
9764          fac=fac+faccav
9765 C 667     continue
9766          endif
9767 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
9768 C     &   enecavtube(i),faccav
9769 C         print *,"licz=",
9770 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9771 C         print *,"finene=",enetube(i+nres)+enecavtube(i)
9772          do j=1,3
9773           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9774           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9775          enddo
9776         enddo
9777 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
9778 C        do i=itube_start,itube_end
9779 C        enecav(i)=0.0
9780 C        iti=itype(i)
9781 C        if (acavtub(iti).eq.0.0) cycle
9782
9783
9784
9785         do i=itube_start,itube_end
9786           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i)
9787      & +enecavtube(i+nres)
9788         enddo
9789 C        print *,"ETUBE", etube
9790         return
9791         end
9792 C TO DO 1) add to total energy
9793 C       2) add to gradient summation
9794 C       3) add reading parameters (AND of course oppening of PARAM file)
9795 C       4) add reading the center of tube
9796 C       5) add COMMONs
9797 C       6) add to zerograd
9798