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           ees=ees+eesij
2353           else
2354           fac_shield(i)=1.0
2355           fac_shield(j)=1.0
2356           eesij=(el1+el2)
2357           ees=ees+eesij
2358           endif
2359 C          ees=ees+eesij
2360           evdw1=evdw1+evdwij*sss
2361 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2362 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2363 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2364 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2365 C
2366 C Calculate contributions to the Cartesian gradient.
2367 C
2368 #ifdef SPLITELE
2369           facvdw=-6*rrmij*(ev1+evdwij)*sss
2370           facel=-3*rrmij*(el1+eesij)
2371           fac1=fac
2372           erij(1)=xj*rmij
2373           erij(2)=yj*rmij
2374           erij(3)=zj*rmij
2375           if (calc_grad) then
2376 *
2377 * Radial derivatives. First process both termini of the fragment (i,j)
2378 *
2379           ggg(1)=facel*xj
2380           ggg(2)=facel*yj
2381           ggg(3)=facel*zj
2382
2383           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2384      &  (shield_mode.gt.0)) then
2385 C          print *,i,j
2386           do ilist=1,ishield_list(i)
2387            iresshield=shield_list(ilist,i)
2388            do k=1,3
2389            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2390      &      *2.0
2391            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2392      &              rlocshield
2393      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2394             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2395 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2396 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2397 C             if (iresshield.gt.i) then
2398 C               do ishi=i+1,iresshield-1
2399 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2400 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2401 C
2402 C              enddo
2403 C             else
2404 C               do ishi=iresshield,i
2405 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2406 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2407 C
2408 C               enddo
2409 C              endif
2410 C           enddo
2411 C          enddo
2412            enddo
2413           enddo
2414           do ilist=1,ishield_list(j)
2415            iresshield=shield_list(ilist,j)
2416            do k=1,3
2417            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2418      &     *2.0
2419            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2420      &              rlocshield
2421      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2422            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2423            enddo
2424           enddo
2425
2426           do k=1,3
2427             gshieldc(k,i)=gshieldc(k,i)+
2428      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2429             gshieldc(k,j)=gshieldc(k,j)+
2430      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2431             gshieldc(k,i-1)=gshieldc(k,i-1)+
2432      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2433             gshieldc(k,j-1)=gshieldc(k,j-1)+
2434      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2435
2436            enddo
2437            endif
2438
2439           do k=1,3
2440             ghalf=0.5D0*ggg(k)
2441             gelc(k,i)=gelc(k,i)+ghalf
2442             gelc(k,j)=gelc(k,j)+ghalf
2443           enddo
2444 *
2445 * Loop over residues i+1 thru j-1.
2446 *
2447           do k=i+1,j-1
2448             do l=1,3
2449               gelc(l,k)=gelc(l,k)+ggg(l)
2450             enddo
2451           enddo
2452 C          ggg(1)=facvdw*xj
2453 C          ggg(2)=facvdw*yj
2454 C          ggg(3)=facvdw*zj
2455           if (sss.gt.0.0) then
2456           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2457           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2458           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2459           else
2460           ggg(1)=0.0
2461           ggg(2)=0.0
2462           ggg(3)=0.0
2463           endif
2464           do k=1,3
2465             ghalf=0.5D0*ggg(k)
2466             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2467             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2468           enddo
2469 *
2470 * Loop over residues i+1 thru j-1.
2471 *
2472           do k=i+1,j-1
2473             do l=1,3
2474               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2475             enddo
2476           enddo
2477 #else
2478           facvdw=(ev1+evdwij)*sss
2479           facel=el1+eesij
2480           fac1=fac
2481           fac=-3*rrmij*(facvdw+facvdw+facel)
2482           erij(1)=xj*rmij
2483           erij(2)=yj*rmij
2484           erij(3)=zj*rmij
2485           if (calc_grad) then
2486 *
2487 * Radial derivatives. First process both termini of the fragment (i,j)
2488 *
2489           ggg(1)=fac*xj
2490           ggg(2)=fac*yj
2491           ggg(3)=fac*zj
2492           do k=1,3
2493             ghalf=0.5D0*ggg(k)
2494             gelc(k,i)=gelc(k,i)+ghalf
2495             gelc(k,j)=gelc(k,j)+ghalf
2496           enddo
2497 *
2498 * Loop over residues i+1 thru j-1.
2499 *
2500           do k=i+1,j-1
2501             do l=1,3
2502               gelc(l,k)=gelc(l,k)+ggg(l)
2503             enddo
2504           enddo
2505 #endif
2506 *
2507 * Angular part
2508 *
2509           ecosa=2.0D0*fac3*fac1+fac4
2510           fac4=-3.0D0*fac4
2511           fac3=-6.0D0*fac3
2512           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2513           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2514           do k=1,3
2515             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2516             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2517           enddo
2518 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2519 cd   &          (dcosg(k),k=1,3)
2520           do k=1,3
2521             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2522      &      *fac_shield(i)**2*fac_shield(j)**2
2523           enddo
2524           do k=1,3
2525             ghalf=0.5D0*ggg(k)
2526             gelc(k,i)=gelc(k,i)+ghalf
2527      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2528      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2529      &           *fac_shield(i)**2*fac_shield(j)**2
2530
2531             gelc(k,j)=gelc(k,j)+ghalf
2532      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2533      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2534      &           *fac_shield(i)**2*fac_shield(j)**2
2535           enddo
2536           do k=i+1,j-1
2537             do l=1,3
2538               gelc(l,k)=gelc(l,k)+ggg(l)
2539             enddo
2540           enddo
2541           endif
2542
2543           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2544      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2545      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2546 C
2547 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2548 C   energy of a peptide unit is assumed in the form of a second-order
2549 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2550 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2551 C   are computed for EVERY pair of non-contiguous peptide groups.
2552 C
2553           if (j.lt.nres-1) then
2554             j1=j+1
2555             j2=j-1
2556           else
2557             j1=j-1
2558             j2=j-2
2559           endif
2560           kkk=0
2561           do k=1,2
2562             do l=1,2
2563               kkk=kkk+1
2564               muij(kkk)=mu(k,i)*mu(l,j)
2565             enddo
2566           enddo
2567 cd         write (iout,*) 'EELEC: i',i,' j',j
2568 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2569 cd          write(iout,*) 'muij',muij
2570           ury=scalar(uy(1,i),erij)
2571           urz=scalar(uz(1,i),erij)
2572           vry=scalar(uy(1,j),erij)
2573           vrz=scalar(uz(1,j),erij)
2574           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2575           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2576           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2577           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2578 C For diagnostics only
2579 cd          a22=1.0d0
2580 cd          a23=1.0d0
2581 cd          a32=1.0d0
2582 cd          a33=1.0d0
2583           fac=dsqrt(-ael6i)*r3ij
2584 cd          write (2,*) 'fac=',fac
2585 C For diagnostics only
2586 cd          fac=1.0d0
2587           a22=a22*fac
2588           a23=a23*fac
2589           a32=a32*fac
2590           a33=a33*fac
2591 cd          write (iout,'(4i5,4f10.5)')
2592 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2593 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2594 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2595 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2596 cd          write (iout,'(4f10.5)')
2597 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2598 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2599 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2600 cd           write (iout,'(2i3,9f10.5/)') i,j,
2601 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2602           if (calc_grad) then
2603 C Derivatives of the elements of A in virtual-bond vectors
2604           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2605 cd          do k=1,3
2606 cd            do l=1,3
2607 cd              erder(k,l)=0.0d0
2608 cd            enddo
2609 cd          enddo
2610           do k=1,3
2611             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2612             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2613             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2614             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2615             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2616             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2617             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2618             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2619             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2620             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2621             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2622             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2623           enddo
2624 cd          do k=1,3
2625 cd            do l=1,3
2626 cd              uryg(k,l)=0.0d0
2627 cd              urzg(k,l)=0.0d0
2628 cd              vryg(k,l)=0.0d0
2629 cd              vrzg(k,l)=0.0d0
2630 cd            enddo
2631 cd          enddo
2632 C Compute radial contributions to the gradient
2633           facr=-3.0d0*rrmij
2634           a22der=a22*facr
2635           a23der=a23*facr
2636           a32der=a32*facr
2637           a33der=a33*facr
2638 cd          a22der=0.0d0
2639 cd          a23der=0.0d0
2640 cd          a32der=0.0d0
2641 cd          a33der=0.0d0
2642           agg(1,1)=a22der*xj
2643           agg(2,1)=a22der*yj
2644           agg(3,1)=a22der*zj
2645           agg(1,2)=a23der*xj
2646           agg(2,2)=a23der*yj
2647           agg(3,2)=a23der*zj
2648           agg(1,3)=a32der*xj
2649           agg(2,3)=a32der*yj
2650           agg(3,3)=a32der*zj
2651           agg(1,4)=a33der*xj
2652           agg(2,4)=a33der*yj
2653           agg(3,4)=a33der*zj
2654 C Add the contributions coming from er
2655           fac3=-3.0d0*fac
2656           do k=1,3
2657             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2658             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2659             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2660             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2661           enddo
2662           do k=1,3
2663 C Derivatives in DC(i)
2664             ghalf1=0.5d0*agg(k,1)
2665             ghalf2=0.5d0*agg(k,2)
2666             ghalf3=0.5d0*agg(k,3)
2667             ghalf4=0.5d0*agg(k,4)
2668             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2669      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2670             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2671      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2672             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2673      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2674             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2675      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2676 C Derivatives in DC(i+1)
2677             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2678      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2679             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2680      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2681             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2682      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2683             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2684      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2685 C Derivatives in DC(j)
2686             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2687      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2688             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2689      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2690             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2691      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2692             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2693      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2694 C Derivatives in DC(j+1) or DC(nres-1)
2695             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2696      &      -3.0d0*vryg(k,3)*ury)
2697             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2698      &      -3.0d0*vrzg(k,3)*ury)
2699             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2700      &      -3.0d0*vryg(k,3)*urz)
2701             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2702      &      -3.0d0*vrzg(k,3)*urz)
2703 cd            aggi(k,1)=ghalf1
2704 cd            aggi(k,2)=ghalf2
2705 cd            aggi(k,3)=ghalf3
2706 cd            aggi(k,4)=ghalf4
2707 C Derivatives in DC(i+1)
2708 cd            aggi1(k,1)=agg(k,1)
2709 cd            aggi1(k,2)=agg(k,2)
2710 cd            aggi1(k,3)=agg(k,3)
2711 cd            aggi1(k,4)=agg(k,4)
2712 C Derivatives in DC(j)
2713 cd            aggj(k,1)=ghalf1
2714 cd            aggj(k,2)=ghalf2
2715 cd            aggj(k,3)=ghalf3
2716 cd            aggj(k,4)=ghalf4
2717 C Derivatives in DC(j+1)
2718 cd            aggj1(k,1)=0.0d0
2719 cd            aggj1(k,2)=0.0d0
2720 cd            aggj1(k,3)=0.0d0
2721 cd            aggj1(k,4)=0.0d0
2722             if (j.eq.nres-1 .and. i.lt.j-2) then
2723               do l=1,4
2724                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2725 cd                aggj1(k,l)=agg(k,l)
2726               enddo
2727             endif
2728           enddo
2729           endif
2730 c          goto 11111
2731 C Check the loc-el terms by numerical integration
2732           acipa(1,1)=a22
2733           acipa(1,2)=a23
2734           acipa(2,1)=a32
2735           acipa(2,2)=a33
2736           a22=-a22
2737           a23=-a23
2738           do l=1,2
2739             do k=1,3
2740               agg(k,l)=-agg(k,l)
2741               aggi(k,l)=-aggi(k,l)
2742               aggi1(k,l)=-aggi1(k,l)
2743               aggj(k,l)=-aggj(k,l)
2744               aggj1(k,l)=-aggj1(k,l)
2745             enddo
2746           enddo
2747           if (j.lt.nres-1) then
2748             a22=-a22
2749             a32=-a32
2750             do l=1,3,2
2751               do k=1,3
2752                 agg(k,l)=-agg(k,l)
2753                 aggi(k,l)=-aggi(k,l)
2754                 aggi1(k,l)=-aggi1(k,l)
2755                 aggj(k,l)=-aggj(k,l)
2756                 aggj1(k,l)=-aggj1(k,l)
2757               enddo
2758             enddo
2759           else
2760             a22=-a22
2761             a23=-a23
2762             a32=-a32
2763             a33=-a33
2764             do l=1,4
2765               do k=1,3
2766                 agg(k,l)=-agg(k,l)
2767                 aggi(k,l)=-aggi(k,l)
2768                 aggi1(k,l)=-aggi1(k,l)
2769                 aggj(k,l)=-aggj(k,l)
2770                 aggj1(k,l)=-aggj1(k,l)
2771               enddo
2772             enddo
2773           endif
2774           ENDIF ! WCORR
2775 11111     continue
2776           IF (wel_loc.gt.0.0d0) THEN
2777 C Contribution to the local-electrostatic energy coming from the i-j pair
2778           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2779      &     +a33*muij(4)
2780 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2781 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2782           if (shield_mode.eq.0) then
2783            fac_shield(i)=1.0
2784            fac_shield(j)=1.0
2785 C          else
2786 C           fac_shield(i)=0.4
2787 C           fac_shield(j)=0.6
2788           endif
2789           eel_loc_ij=eel_loc_ij
2790      &    *fac_shield(i)*fac_shield(j)
2791           eel_loc=eel_loc+eel_loc_ij
2792 C Partial derivatives in virtual-bond dihedral angles gamma
2793           if (calc_grad) then
2794           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2795      &  (shield_mode.gt.0)) then
2796 C          print *,i,j
2797
2798           do ilist=1,ishield_list(i)
2799            iresshield=shield_list(ilist,i)
2800            do k=1,3
2801            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2802      &                                          /fac_shield(i)
2803 C     &      *2.0
2804            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2805      &              rlocshield
2806      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2807             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2808      &      +rlocshield
2809            enddo
2810           enddo
2811           do ilist=1,ishield_list(j)
2812            iresshield=shield_list(ilist,j)
2813            do k=1,3
2814            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2815      &                                       /fac_shield(j)
2816 C     &     *2.0
2817            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2818      &              rlocshield
2819      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2820            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2821      &             +rlocshield
2822
2823            enddo
2824           enddo
2825           do k=1,3
2826             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2827      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2828             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2829      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2830             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2831      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2832             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2833      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2834            enddo
2835            endif
2836           if (i.gt.1)
2837      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2838      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2839      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2840      &    *fac_shield(i)*fac_shield(j)
2841           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2842      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2843      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2844      &    *fac_shield(i)*fac_shield(j)
2845
2846 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2847 cd          write(iout,*) 'agg  ',agg
2848 cd          write(iout,*) 'aggi ',aggi
2849 cd          write(iout,*) 'aggi1',aggi1
2850 cd          write(iout,*) 'aggj ',aggj
2851 cd          write(iout,*) 'aggj1',aggj1
2852
2853 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2854           do l=1,3
2855             ggg(l)=agg(l,1)*muij(1)+
2856      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2857      &    *fac_shield(i)*fac_shield(j)
2858
2859           enddo
2860           do k=i+2,j2
2861             do l=1,3
2862               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2863             enddo
2864           enddo
2865 C Remaining derivatives of eello
2866           do l=1,3
2867             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2868      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2869      &    *fac_shield(i)*fac_shield(j)
2870
2871             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2872      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2873      &    *fac_shield(i)*fac_shield(j)
2874
2875             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2876      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2877      &    *fac_shield(i)*fac_shield(j)
2878
2879             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2880      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2881      &    *fac_shield(i)*fac_shield(j)
2882
2883           enddo
2884           endif
2885           ENDIF
2886           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2887 C Contributions from turns
2888             a_temp(1,1)=a22
2889             a_temp(1,2)=a23
2890             a_temp(2,1)=a32
2891             a_temp(2,2)=a33
2892             call eturn34(i,j,eello_turn3,eello_turn4)
2893           endif
2894 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2895           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2896 C
2897 C Calculate the contact function. The ith column of the array JCONT will
2898 C contain the numbers of atoms that make contacts with the atom I (of numbers
2899 C greater than I). The arrays FACONT and GACONT will contain the values of
2900 C the contact function and its derivative.
2901 c           r0ij=1.02D0*rpp(iteli,itelj)
2902 c           r0ij=1.11D0*rpp(iteli,itelj)
2903             r0ij=2.20D0*rpp(iteli,itelj)
2904 c           r0ij=1.55D0*rpp(iteli,itelj)
2905             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2906             if (fcont.gt.0.0D0) then
2907               num_conti=num_conti+1
2908               if (num_conti.gt.maxconts) then
2909                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2910      &                         ' will skip next contacts for this conf.'
2911               else
2912                 jcont_hb(num_conti,i)=j
2913                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2914      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2915 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2916 C  terms.
2917                 d_cont(num_conti,i)=rij
2918 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2919 C     --- Electrostatic-interaction matrix ---
2920                 a_chuj(1,1,num_conti,i)=a22
2921                 a_chuj(1,2,num_conti,i)=a23
2922                 a_chuj(2,1,num_conti,i)=a32
2923                 a_chuj(2,2,num_conti,i)=a33
2924 C     --- Gradient of rij
2925                 do kkk=1,3
2926                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2927                 enddo
2928 c             if (i.eq.1) then
2929 c                a_chuj(1,1,num_conti,i)=-0.61d0
2930 c                a_chuj(1,2,num_conti,i)= 0.4d0
2931 c                a_chuj(2,1,num_conti,i)= 0.65d0
2932 c                a_chuj(2,2,num_conti,i)= 0.50d0
2933 c             else if (i.eq.2) then
2934 c                a_chuj(1,1,num_conti,i)= 0.0d0
2935 c                a_chuj(1,2,num_conti,i)= 0.0d0
2936 c                a_chuj(2,1,num_conti,i)= 0.0d0
2937 c                a_chuj(2,2,num_conti,i)= 0.0d0
2938 c             endif
2939 C     --- and its gradients
2940 cd                write (iout,*) 'i',i,' j',j
2941 cd                do kkk=1,3
2942 cd                write (iout,*) 'iii 1 kkk',kkk
2943 cd                write (iout,*) agg(kkk,:)
2944 cd                enddo
2945 cd                do kkk=1,3
2946 cd                write (iout,*) 'iii 2 kkk',kkk
2947 cd                write (iout,*) aggi(kkk,:)
2948 cd                enddo
2949 cd                do kkk=1,3
2950 cd                write (iout,*) 'iii 3 kkk',kkk
2951 cd                write (iout,*) aggi1(kkk,:)
2952 cd                enddo
2953 cd                do kkk=1,3
2954 cd                write (iout,*) 'iii 4 kkk',kkk
2955 cd                write (iout,*) aggj(kkk,:)
2956 cd                enddo
2957 cd                do kkk=1,3
2958 cd                write (iout,*) 'iii 5 kkk',kkk
2959 cd                write (iout,*) aggj1(kkk,:)
2960 cd                enddo
2961                 kkll=0
2962                 do k=1,2
2963                   do l=1,2
2964                     kkll=kkll+1
2965                     do m=1,3
2966                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2967                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2968                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2969                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2970                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2971 c                      do mm=1,5
2972 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2973 c                      enddo
2974                     enddo
2975                   enddo
2976                 enddo
2977                 ENDIF
2978                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2979 C Calculate contact energies
2980                 cosa4=4.0D0*cosa
2981                 wij=cosa-3.0D0*cosb*cosg
2982                 cosbg1=cosb+cosg
2983                 cosbg2=cosb-cosg
2984 c               fac3=dsqrt(-ael6i)/r0ij**3
2985                 fac3=dsqrt(-ael6i)*r3ij
2986                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2987                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2988                 if (shield_mode.eq.0) then
2989                 fac_shield(i)=1.0d0
2990                 fac_shield(j)=1.0d0
2991                 else
2992                 ees0plist(num_conti,i)=j
2993 C                fac_shield(i)=0.4d0
2994 C                fac_shield(j)=0.6d0
2995                 endif
2996 c               ees0mij=0.0D0
2997                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2998      &          *fac_shield(i)*fac_shield(j)
2999
3000                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3001      &          *fac_shield(i)*fac_shield(j)
3002
3003 C Diagnostics. Comment out or remove after debugging!
3004 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3005 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3006 c               ees0m(num_conti,i)=0.0D0
3007 C End diagnostics.
3008 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3009 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3010                 facont_hb(num_conti,i)=fcont
3011                 if (calc_grad) then
3012 C Angular derivatives of the contact function
3013                 ees0pij1=fac3/ees0pij
3014                 ees0mij1=fac3/ees0mij
3015                 fac3p=-3.0D0*fac3*rrmij
3016                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3017                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3018 c               ees0mij1=0.0D0
3019                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3020                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3021                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3022                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3023                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3024                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3025                 ecosap=ecosa1+ecosa2
3026                 ecosbp=ecosb1+ecosb2
3027                 ecosgp=ecosg1+ecosg2
3028                 ecosam=ecosa1-ecosa2
3029                 ecosbm=ecosb1-ecosb2
3030                 ecosgm=ecosg1-ecosg2
3031 C Diagnostics
3032 c               ecosap=ecosa1
3033 c               ecosbp=ecosb1
3034 c               ecosgp=ecosg1
3035 c               ecosam=0.0D0
3036 c               ecosbm=0.0D0
3037 c               ecosgm=0.0D0
3038 C End diagnostics
3039                 fprimcont=fprimcont/rij
3040 cd              facont_hb(num_conti,i)=1.0D0
3041 C Following line is for diagnostics.
3042 cd              fprimcont=0.0D0
3043                 do k=1,3
3044                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3045                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3046                 enddo
3047                 do k=1,3
3048                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3049                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3050                 enddo
3051                 gggp(1)=gggp(1)+ees0pijp*xj
3052                 gggp(2)=gggp(2)+ees0pijp*yj
3053                 gggp(3)=gggp(3)+ees0pijp*zj
3054                 gggm(1)=gggm(1)+ees0mijp*xj
3055                 gggm(2)=gggm(2)+ees0mijp*yj
3056                 gggm(3)=gggm(3)+ees0mijp*zj
3057 C Derivatives due to the contact function
3058                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3059                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3060                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3061                 do k=1,3
3062                   ghalfp=0.5D0*gggp(k)
3063                   ghalfm=0.5D0*gggm(k)
3064                   gacontp_hb1(k,num_conti,i)=ghalfp
3065      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3066      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3067      &          *fac_shield(i)*fac_shield(j)
3068
3069                   gacontp_hb2(k,num_conti,i)=ghalfp
3070      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3071      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3072      &          *fac_shield(i)*fac_shield(j)
3073
3074                   gacontp_hb3(k,num_conti,i)=gggp(k)
3075      &          *fac_shield(i)*fac_shield(j)
3076
3077                   gacontm_hb1(k,num_conti,i)=ghalfm
3078      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3079      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3080      &          *fac_shield(i)*fac_shield(j)
3081
3082                   gacontm_hb2(k,num_conti,i)=ghalfm
3083      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3084      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3085      &          *fac_shield(i)*fac_shield(j)
3086
3087                   gacontm_hb3(k,num_conti,i)=gggm(k)
3088      &          *fac_shield(i)*fac_shield(j)
3089
3090                 enddo
3091                 endif
3092 C Diagnostics. Comment out or remove after debugging!
3093 cdiag           do k=1,3
3094 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3095 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3096 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3097 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3098 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3099 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3100 cdiag           enddo
3101               ENDIF ! wcorr
3102               endif  ! num_conti.le.maxconts
3103             endif  ! fcont.gt.0
3104           endif    ! j.gt.i+1
3105  1216     continue
3106         enddo ! j
3107         num_cont_hb(i)=num_conti
3108  1215   continue
3109       enddo   ! i
3110 cd      do i=1,nres
3111 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3112 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3113 cd      enddo
3114 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3115 ccc      eel_loc=eel_loc+eello_turn3
3116       return
3117       end
3118 C-----------------------------------------------------------------------------
3119       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3120 C Third- and fourth-order contributions from turns
3121       implicit real*8 (a-h,o-z)
3122       include 'DIMENSIONS'
3123       include 'sizesclu.dat'
3124       include 'COMMON.IOUNITS'
3125       include 'COMMON.GEO'
3126       include 'COMMON.VAR'
3127       include 'COMMON.LOCAL'
3128       include 'COMMON.CHAIN'
3129       include 'COMMON.DERIV'
3130       include 'COMMON.INTERACT'
3131       include 'COMMON.CONTACTS'
3132       include 'COMMON.TORSION'
3133       include 'COMMON.VECTORS'
3134       include 'COMMON.FFIELD'
3135       include 'COMMON.SHIELD'
3136       include 'COMMON.CONTROL'
3137
3138       dimension ggg(3)
3139       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3140      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3141      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3142       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3143      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3144       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3145       if (j.eq.i+2) then
3146       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3147 C changes suggested by Ana to avoid out of bounds
3148 C     & .or.((i+5).gt.nres)
3149 C     & .or.((i-1).le.0)
3150 C end of changes suggested by Ana
3151      &    .or. itype(i+2).eq.ntyp1
3152      &    .or. itype(i+3).eq.ntyp1
3153 C     &    .or. itype(i+5).eq.ntyp1
3154 C     &    .or. itype(i).eq.ntyp1
3155 C     &    .or. itype(i-1).eq.ntyp1
3156      &    ) goto 179
3157
3158 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3159 C
3160 C               Third-order contributions
3161 C
3162 C                 (i+2)o----(i+3)
3163 C                      | |
3164 C                      | |
3165 C                 (i+1)o----i
3166 C
3167 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3168 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3169         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3170         call transpose2(auxmat(1,1),auxmat1(1,1))
3171         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3172         if (shield_mode.eq.0) then
3173         fac_shield(i)=1.0
3174         fac_shield(j)=1.0
3175 C        else
3176 C        fac_shield(i)=0.4
3177 C        fac_shield(j)=0.6
3178         endif
3179         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3180      &  *fac_shield(i)*fac_shield(j)
3181         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3182      &  *fac_shield(i)*fac_shield(j)
3183
3184 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3185 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3186 cd     &    ' eello_turn3_num',4*eello_turn3_num
3187         if (calc_grad) then
3188 C Derivatives in shield mode
3189           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3190      &  (shield_mode.gt.0)) then
3191 C          print *,i,j
3192
3193           do ilist=1,ishield_list(i)
3194            iresshield=shield_list(ilist,i)
3195            do k=1,3
3196            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3197 C     &      *2.0
3198            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3199      &              rlocshield
3200      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3201             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3202      &      +rlocshield
3203            enddo
3204           enddo
3205           do ilist=1,ishield_list(j)
3206            iresshield=shield_list(ilist,j)
3207            do k=1,3
3208            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3209 C     &     *2.0
3210            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3211      &              rlocshield
3212      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3213            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3214      &             +rlocshield
3215
3216            enddo
3217           enddo
3218
3219           do k=1,3
3220             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3221      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3222             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3223      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3224             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3225      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3226             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3227      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3228            enddo
3229            endif
3230
3231 C Derivatives in gamma(i)
3232         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3233         call transpose2(auxmat2(1,1),pizda(1,1))
3234         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3235         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3236      &   *fac_shield(i)*fac_shield(j)
3237
3238 C Derivatives in gamma(i+1)
3239         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3240         call transpose2(auxmat2(1,1),pizda(1,1))
3241         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3242         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3243      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3244      &   *fac_shield(i)*fac_shield(j)
3245
3246 C Cartesian derivatives
3247         do l=1,3
3248           a_temp(1,1)=aggi(l,1)
3249           a_temp(1,2)=aggi(l,2)
3250           a_temp(2,1)=aggi(l,3)
3251           a_temp(2,2)=aggi(l,4)
3252           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3253           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3254      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3255      &   *fac_shield(i)*fac_shield(j)
3256
3257           a_temp(1,1)=aggi1(l,1)
3258           a_temp(1,2)=aggi1(l,2)
3259           a_temp(2,1)=aggi1(l,3)
3260           a_temp(2,2)=aggi1(l,4)
3261           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3262           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3263      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3264      &   *fac_shield(i)*fac_shield(j)
3265
3266           a_temp(1,1)=aggj(l,1)
3267           a_temp(1,2)=aggj(l,2)
3268           a_temp(2,1)=aggj(l,3)
3269           a_temp(2,2)=aggj(l,4)
3270           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3271           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3272      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3273      &   *fac_shield(i)*fac_shield(j)
3274
3275           a_temp(1,1)=aggj1(l,1)
3276           a_temp(1,2)=aggj1(l,2)
3277           a_temp(2,1)=aggj1(l,3)
3278           a_temp(2,2)=aggj1(l,4)
3279           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3280           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3281      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3282      &   *fac_shield(i)*fac_shield(j)
3283
3284         enddo
3285         endif
3286   179 continue
3287       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3288       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3289 C changes suggested by Ana to avoid out of bounds
3290 C     & .or.((i+5).gt.nres)
3291 C     & .or.((i-1).le.0)
3292 C end of changes suggested by Ana
3293      &    .or. itype(i+3).eq.ntyp1
3294      &    .or. itype(i+4).eq.ntyp1
3295 C     &    .or. itype(i+5).eq.ntyp1
3296      &    .or. itype(i).eq.ntyp1
3297 C     &    .or. itype(i-1).eq.ntyp1
3298      &    ) goto 178
3299
3300 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3301 C
3302 C               Fourth-order contributions
3303 C
3304 C                 (i+3)o----(i+4)
3305 C                     /  |
3306 C               (i+2)o   |
3307 C                     \  |
3308 C                 (i+1)o----i
3309 C
3310 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3311 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3312         iti1=itortyp(itype(i+1))
3313         iti2=itortyp(itype(i+2))
3314         iti3=itortyp(itype(i+3))
3315         call transpose2(EUg(1,1,i+1),e1t(1,1))
3316         call transpose2(Eug(1,1,i+2),e2t(1,1))
3317         call transpose2(Eug(1,1,i+3),e3t(1,1))
3318         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3319         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3320         s1=scalar2(b1(1,iti2),auxvec(1))
3321         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3322         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3323         s2=scalar2(b1(1,iti1),auxvec(1))
3324         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3325         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3326         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3327         if (shield_mode.eq.0) then
3328         fac_shield(i)=1.0
3329         fac_shield(j)=1.0
3330 C        else
3331 C        fac_shield(i)=0.4
3332 C        fac_shield(j)=0.6
3333         endif
3334         eello_turn4=eello_turn4-(s1+s2+s3)
3335      &  *fac_shield(i)*fac_shield(j)
3336         eello_t4=-(s1+s2+s3)
3337      &  *fac_shield(i)*fac_shield(j)
3338
3339 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3340 cd     &    ' eello_turn4_num',8*eello_turn4_num
3341 C Derivatives in gamma(i)
3342         if (calc_grad) then
3343           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3344      &  (shield_mode.gt.0)) then
3345 C          print *,i,j
3346
3347           do ilist=1,ishield_list(i)
3348            iresshield=shield_list(ilist,i)
3349            do k=1,3
3350            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3351 C     &      *2.0
3352            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3353      &              rlocshield
3354      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3355             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3356      &      +rlocshield
3357            enddo
3358           enddo
3359           do ilist=1,ishield_list(j)
3360            iresshield=shield_list(ilist,j)
3361            do k=1,3
3362            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3363 C     &     *2.0
3364            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3365      &              rlocshield
3366      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3367            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3368      &             +rlocshield
3369
3370            enddo
3371           enddo
3372
3373           do k=1,3
3374             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3375      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3376             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3377      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3378             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3379      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3380             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3381      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3382            enddo
3383            endif
3384
3385         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3386         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3387         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3388         s1=scalar2(b1(1,iti2),auxvec(1))
3389         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3390         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3391         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3392      &  *fac_shield(i)*fac_shield(j)
3393
3394 C Derivatives in gamma(i+1)
3395         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3396         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3397         s2=scalar2(b1(1,iti1),auxvec(1))
3398         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3399         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3400         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3401         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3402      &  *fac_shield(i)*fac_shield(j)
3403
3404 C Derivatives in gamma(i+2)
3405         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3406         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3407         s1=scalar2(b1(1,iti2),auxvec(1))
3408         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3409         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3410         s2=scalar2(b1(1,iti1),auxvec(1))
3411         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3412         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3413         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3414         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3415      &  *fac_shield(i)*fac_shield(j)
3416
3417 C Cartesian derivatives
3418 C Derivatives of this turn contributions in DC(i+2)
3419         if (j.lt.nres-1) then
3420           do l=1,3
3421             a_temp(1,1)=agg(l,1)
3422             a_temp(1,2)=agg(l,2)
3423             a_temp(2,1)=agg(l,3)
3424             a_temp(2,2)=agg(l,4)
3425             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3426             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3427             s1=scalar2(b1(1,iti2),auxvec(1))
3428             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3429             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3430             s2=scalar2(b1(1,iti1),auxvec(1))
3431             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3432             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3433             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3434             ggg(l)=-(s1+s2+s3)
3435             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3436      &  *fac_shield(i)*fac_shield(j)
3437
3438           enddo
3439         endif
3440 C Remaining derivatives of this turn contribution
3441         do l=1,3
3442           a_temp(1,1)=aggi(l,1)
3443           a_temp(1,2)=aggi(l,2)
3444           a_temp(2,1)=aggi(l,3)
3445           a_temp(2,2)=aggi(l,4)
3446           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3447           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3448           s1=scalar2(b1(1,iti2),auxvec(1))
3449           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3450           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3451           s2=scalar2(b1(1,iti1),auxvec(1))
3452           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3453           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3454           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3455           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3456      &  *fac_shield(i)*fac_shield(j)
3457
3458           a_temp(1,1)=aggi1(l,1)
3459           a_temp(1,2)=aggi1(l,2)
3460           a_temp(2,1)=aggi1(l,3)
3461           a_temp(2,2)=aggi1(l,4)
3462           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3463           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3464           s1=scalar2(b1(1,iti2),auxvec(1))
3465           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3466           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3467           s2=scalar2(b1(1,iti1),auxvec(1))
3468           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3469           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3470           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3471           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3472      &  *fac_shield(i)*fac_shield(j)
3473
3474           a_temp(1,1)=aggj(l,1)
3475           a_temp(1,2)=aggj(l,2)
3476           a_temp(2,1)=aggj(l,3)
3477           a_temp(2,2)=aggj(l,4)
3478           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3479           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3480           s1=scalar2(b1(1,iti2),auxvec(1))
3481           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3482           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3483           s2=scalar2(b1(1,iti1),auxvec(1))
3484           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3485           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3486           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3487           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3488      &  *fac_shield(i)*fac_shield(j)
3489
3490           a_temp(1,1)=aggj1(l,1)
3491           a_temp(1,2)=aggj1(l,2)
3492           a_temp(2,1)=aggj1(l,3)
3493           a_temp(2,2)=aggj1(l,4)
3494           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3495           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3496           s1=scalar2(b1(1,iti2),auxvec(1))
3497           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3498           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3499           s2=scalar2(b1(1,iti1),auxvec(1))
3500           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3501           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3502           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3503           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3504      &  *fac_shield(i)*fac_shield(j)
3505
3506         enddo
3507         endif
3508   178 continue
3509       endif
3510       return
3511       end
3512 C-----------------------------------------------------------------------------
3513       subroutine vecpr(u,v,w)
3514       implicit real*8(a-h,o-z)
3515       dimension u(3),v(3),w(3)
3516       w(1)=u(2)*v(3)-u(3)*v(2)
3517       w(2)=-u(1)*v(3)+u(3)*v(1)
3518       w(3)=u(1)*v(2)-u(2)*v(1)
3519       return
3520       end
3521 C-----------------------------------------------------------------------------
3522       subroutine unormderiv(u,ugrad,unorm,ungrad)
3523 C This subroutine computes the derivatives of a normalized vector u, given
3524 C the derivatives computed without normalization conditions, ugrad. Returns
3525 C ungrad.
3526       implicit none
3527       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3528       double precision vec(3)
3529       double precision scalar
3530       integer i,j
3531 c      write (2,*) 'ugrad',ugrad
3532 c      write (2,*) 'u',u
3533       do i=1,3
3534         vec(i)=scalar(ugrad(1,i),u(1))
3535       enddo
3536 c      write (2,*) 'vec',vec
3537       do i=1,3
3538         do j=1,3
3539           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3540         enddo
3541       enddo
3542 c      write (2,*) 'ungrad',ungrad
3543       return
3544       end
3545 C-----------------------------------------------------------------------------
3546       subroutine escp(evdw2,evdw2_14)
3547 C
3548 C This subroutine calculates the excluded-volume interaction energy between
3549 C peptide-group centers and side chains and its gradient in virtual-bond and
3550 C side-chain vectors.
3551 C
3552       implicit real*8 (a-h,o-z)
3553       include 'DIMENSIONS'
3554       include 'sizesclu.dat'
3555       include 'COMMON.GEO'
3556       include 'COMMON.VAR'
3557       include 'COMMON.LOCAL'
3558       include 'COMMON.CHAIN'
3559       include 'COMMON.DERIV'
3560       include 'COMMON.INTERACT'
3561       include 'COMMON.FFIELD'
3562       include 'COMMON.IOUNITS'
3563       dimension ggg(3)
3564       evdw2=0.0D0
3565       evdw2_14=0.0d0
3566 cd    print '(a)','Enter ESCP'
3567 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3568 c     &  ' scal14',scal14
3569       do i=iatscp_s,iatscp_e
3570         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3571         iteli=itel(i)
3572 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3573 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3574         if (iteli.eq.0) goto 1225
3575         xi=0.5D0*(c(1,i)+c(1,i+1))
3576         yi=0.5D0*(c(2,i)+c(2,i+1))
3577         zi=0.5D0*(c(3,i)+c(3,i+1))
3578 C    Returning the ith atom to box
3579           xi=mod(xi,boxxsize)
3580           if (xi.lt.0) xi=xi+boxxsize
3581           yi=mod(yi,boxysize)
3582           if (yi.lt.0) yi=yi+boxysize
3583           zi=mod(zi,boxzsize)
3584           if (zi.lt.0) zi=zi+boxzsize
3585
3586         do iint=1,nscp_gr(i)
3587
3588         do j=iscpstart(i,iint),iscpend(i,iint)
3589           itypj=iabs(itype(j))
3590           if (itypj.eq.ntyp1) cycle
3591 C Uncomment following three lines for SC-p interactions
3592 c         xj=c(1,nres+j)-xi
3593 c         yj=c(2,nres+j)-yi
3594 c         zj=c(3,nres+j)-zi
3595 C Uncomment following three lines for Ca-p interactions
3596           xj=c(1,j)
3597           yj=c(2,j)
3598           zj=c(3,j)
3599 C returning the jth atom to box
3600           xj=mod(xj,boxxsize)
3601           if (xj.lt.0) xj=xj+boxxsize
3602           yj=mod(yj,boxysize)
3603           if (yj.lt.0) yj=yj+boxysize
3604           zj=mod(zj,boxzsize)
3605           if (zj.lt.0) zj=zj+boxzsize
3606       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3607       xj_safe=xj
3608       yj_safe=yj
3609       zj_safe=zj
3610       subchap=0
3611 C Finding the closest jth atom
3612       do xshift=-1,1
3613       do yshift=-1,1
3614       do zshift=-1,1
3615           xj=xj_safe+xshift*boxxsize
3616           yj=yj_safe+yshift*boxysize
3617           zj=zj_safe+zshift*boxzsize
3618           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3619           if(dist_temp.lt.dist_init) then
3620             dist_init=dist_temp
3621             xj_temp=xj
3622             yj_temp=yj
3623             zj_temp=zj
3624             subchap=1
3625           endif
3626        enddo
3627        enddo
3628        enddo
3629        if (subchap.eq.1) then
3630           xj=xj_temp-xi
3631           yj=yj_temp-yi
3632           zj=zj_temp-zi
3633        else
3634           xj=xj_safe-xi
3635           yj=yj_safe-yi
3636           zj=zj_safe-zi
3637        endif
3638
3639           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3640 C sss is scaling function for smoothing the cutoff gradient otherwise
3641 C the gradient would not be continuouse
3642           sss=sscale(1.0d0/(dsqrt(rrij)))
3643           if (sss.le.0.0d0) cycle
3644           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3645           fac=rrij**expon2
3646           e1=fac*fac*aad(itypj,iteli)
3647           e2=fac*bad(itypj,iteli)
3648           if (iabs(j-i) .le. 2) then
3649             e1=scal14*e1
3650             e2=scal14*e2
3651             evdw2_14=evdw2_14+(e1+e2)*sss
3652           endif
3653           evdwij=e1+e2
3654 c          write (iout,*) i,j,evdwij
3655           evdw2=evdw2+evdwij*sss
3656           if (calc_grad) then
3657 C
3658 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3659 C
3660            fac=-(evdwij+e1)*rrij*sss
3661            fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3662           ggg(1)=xj*fac
3663           ggg(2)=yj*fac
3664           ggg(3)=zj*fac
3665           if (j.lt.i) then
3666 cd          write (iout,*) 'j<i'
3667 C Uncomment following three lines for SC-p interactions
3668 c           do k=1,3
3669 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3670 c           enddo
3671           else
3672 cd          write (iout,*) 'j>i'
3673             do k=1,3
3674               ggg(k)=-ggg(k)
3675 C Uncomment following line for SC-p interactions
3676 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3677             enddo
3678           endif
3679           do k=1,3
3680             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3681           enddo
3682           kstart=min0(i+1,j)
3683           kend=max0(i-1,j-1)
3684 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3685 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3686           do k=kstart,kend
3687             do l=1,3
3688               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3689             enddo
3690           enddo
3691           endif
3692         enddo
3693         enddo ! iint
3694  1225   continue
3695       enddo ! i
3696       do i=1,nct
3697         do j=1,3
3698           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3699           gradx_scp(j,i)=expon*gradx_scp(j,i)
3700         enddo
3701       enddo
3702 C******************************************************************************
3703 C
3704 C                              N O T E !!!
3705 C
3706 C To save time the factor EXPON has been extracted from ALL components
3707 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3708 C use!
3709 C
3710 C******************************************************************************
3711       return
3712       end
3713 C--------------------------------------------------------------------------
3714       subroutine edis(ehpb)
3715 C
3716 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3717 C
3718       implicit real*8 (a-h,o-z)
3719       include 'DIMENSIONS'
3720       include 'sizesclu.dat'
3721       include 'COMMON.SBRIDGE'
3722       include 'COMMON.CHAIN'
3723       include 'COMMON.DERIV'
3724       include 'COMMON.VAR'
3725       include 'COMMON.INTERACT'
3726       include 'COMMON.CONTROL'
3727       dimension ggg(3)
3728       ehpb=0.0D0
3729 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3730 cd    print *,'link_start=',link_start,' link_end=',link_end
3731       if (link_end.eq.0) return
3732       do i=link_start,link_end
3733 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3734 C CA-CA distance used in regularization of structure.
3735         ii=ihpb(i)
3736         jj=jhpb(i)
3737 C iii and jjj point to the residues for which the distance is assigned.
3738         if (ii.gt.nres) then
3739           iii=ii-nres
3740           jjj=jj-nres
3741         else
3742           iii=ii
3743           jjj=jj
3744         endif
3745 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3746 C    distance and angle dependent SS bond potential.
3747 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3748 C     &  iabs(itype(jjj)).eq.1) then
3749 C          call ssbond_ene(iii,jjj,eij)
3750 C          ehpb=ehpb+2*eij
3751 C        else
3752        if (.not.dyn_ss .and. i.le.nss) then
3753          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3754      & iabs(itype(jjj)).eq.1) then
3755           call ssbond_ene(iii,jjj,eij)
3756           ehpb=ehpb+2*eij
3757            endif !ii.gt.neres
3758         else if (ii.gt.nres .and. jj.gt.nres) then
3759 c Restraints from contact prediction
3760           dd=dist(ii,jj)
3761           if (constr_dist.eq.11) then
3762 C            ehpb=ehpb+fordepth(i)**4.0d0
3763 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3764             ehpb=ehpb+fordepth(i)**4.0d0
3765      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3766             fac=fordepth(i)**4.0d0
3767      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3768 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3769 C     &    ehpb,fordepth(i),dd
3770 C             print *,"TUTU"
3771 C            write(iout,*) ehpb,"atu?"
3772 C            ehpb,"tu?"
3773 C            fac=fordepth(i)**4.0d0
3774 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3775            else !constr_dist.eq.11
3776           if (dhpb1(i).gt.0.0d0) then
3777             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3778             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3779 c            write (iout,*) "beta nmr",
3780 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3781           else !dhpb(i).gt.0.00
3782
3783 C Calculate the distance between the two points and its difference from the
3784 C target distance.
3785         dd=dist(ii,jj)
3786         rdis=dd-dhpb(i)
3787 C Get the force constant corresponding to this distance.
3788         waga=forcon(i)
3789 C Calculate the contribution to energy.
3790         ehpb=ehpb+waga*rdis*rdis
3791 C
3792 C Evaluate gradient.
3793 C
3794         fac=waga*rdis/dd
3795         endif !dhpb(i).gt.0
3796         endif
3797 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3798 cd   &   ' waga=',waga,' fac=',fac
3799         do j=1,3
3800           ggg(j)=fac*(c(j,jj)-c(j,ii))
3801         enddo
3802 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3803 C If this is a SC-SC distance, we need to calculate the contributions to the
3804 C Cartesian gradient in the SC vectors (ghpbx).
3805         if (iii.lt.ii) then
3806           do j=1,3
3807             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3808             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3809           enddo
3810         endif
3811         else !ii.gt.nres
3812 C          write(iout,*) "before"
3813           dd=dist(ii,jj)
3814 C          write(iout,*) "after",dd
3815           if (constr_dist.eq.11) then
3816             ehpb=ehpb+fordepth(i)**4.0d0
3817      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3818             fac=fordepth(i)**4.0d0
3819      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3820 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3821 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3822 C            print *,ehpb,"tu?"
3823 C            write(iout,*) ehpb,"btu?",
3824 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3825 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3826 C     &    ehpb,fordepth(i),dd
3827            else
3828           if (dhpb1(i).gt.0.0d0) then
3829             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3830             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3831 c            write (iout,*) "alph nmr",
3832 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3833           else
3834             rdis=dd-dhpb(i)
3835 C Get the force constant corresponding to this distance.
3836             waga=forcon(i)
3837 C Calculate the contribution to energy.
3838             ehpb=ehpb+waga*rdis*rdis
3839 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3840 C
3841 C Evaluate gradient.
3842 C
3843             fac=waga*rdis/dd
3844           endif
3845           endif
3846         do j=1,3
3847           ggg(j)=fac*(c(j,jj)-c(j,ii))
3848         enddo
3849 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3850 C If this is a SC-SC distance, we need to calculate the contributions to the
3851 C Cartesian gradient in the SC vectors (ghpbx).
3852         if (iii.lt.ii) then
3853           do j=1,3
3854             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3855             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3856           enddo
3857         endif
3858         do j=iii,jjj-1
3859           do k=1,3
3860             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3861           enddo
3862         enddo
3863         endif
3864       enddo
3865       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3866       return
3867       end
3868 C--------------------------------------------------------------------------
3869       subroutine ssbond_ene(i,j,eij)
3870 C
3871 C Calculate the distance and angle dependent SS-bond potential energy
3872 C using a free-energy function derived based on RHF/6-31G** ab initio
3873 C calculations of diethyl disulfide.
3874 C
3875 C A. Liwo and U. Kozlowska, 11/24/03
3876 C
3877       implicit real*8 (a-h,o-z)
3878       include 'DIMENSIONS'
3879       include 'sizesclu.dat'
3880       include 'COMMON.SBRIDGE'
3881       include 'COMMON.CHAIN'
3882       include 'COMMON.DERIV'
3883       include 'COMMON.LOCAL'
3884       include 'COMMON.INTERACT'
3885       include 'COMMON.VAR'
3886       include 'COMMON.IOUNITS'
3887       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3888       itypi=iabs(itype(i))
3889       xi=c(1,nres+i)
3890       yi=c(2,nres+i)
3891       zi=c(3,nres+i)
3892       dxi=dc_norm(1,nres+i)
3893       dyi=dc_norm(2,nres+i)
3894       dzi=dc_norm(3,nres+i)
3895       dsci_inv=dsc_inv(itypi)
3896       itypj=iabs(itype(j))
3897       dscj_inv=dsc_inv(itypj)
3898       xj=c(1,nres+j)-xi
3899       yj=c(2,nres+j)-yi
3900       zj=c(3,nres+j)-zi
3901       dxj=dc_norm(1,nres+j)
3902       dyj=dc_norm(2,nres+j)
3903       dzj=dc_norm(3,nres+j)
3904       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3905       rij=dsqrt(rrij)
3906       erij(1)=xj*rij
3907       erij(2)=yj*rij
3908       erij(3)=zj*rij
3909       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3910       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3911       om12=dxi*dxj+dyi*dyj+dzi*dzj
3912       do k=1,3
3913         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3914         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3915       enddo
3916       rij=1.0d0/rij
3917       deltad=rij-d0cm
3918       deltat1=1.0d0-om1
3919       deltat2=1.0d0+om2
3920       deltat12=om2-om1+2.0d0
3921       cosphi=om12-om1*om2
3922       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3923      &  +akct*deltad*deltat12
3924      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3925 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3926 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3927 c     &  " deltat12",deltat12," eij",eij
3928       ed=2*akcm*deltad+akct*deltat12
3929       pom1=akct*deltad
3930       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3931       eom1=-2*akth*deltat1-pom1-om2*pom2
3932       eom2= 2*akth*deltat2+pom1-om1*pom2
3933       eom12=pom2
3934       do k=1,3
3935         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3936       enddo
3937       do k=1,3
3938         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3939      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3940         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3941      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3942       enddo
3943 C
3944 C Calculate the components of the gradient in DC and X
3945 C
3946       do k=i,j-1
3947         do l=1,3
3948           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3949         enddo
3950       enddo
3951       return
3952       end
3953 C--------------------------------------------------------------------------
3954       subroutine ebond(estr)
3955 c
3956 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3957 c
3958       implicit real*8 (a-h,o-z)
3959       include 'DIMENSIONS'
3960       include 'sizesclu.dat'
3961       include 'COMMON.LOCAL'
3962       include 'COMMON.GEO'
3963       include 'COMMON.INTERACT'
3964       include 'COMMON.DERIV'
3965       include 'COMMON.VAR'
3966       include 'COMMON.CHAIN'
3967       include 'COMMON.IOUNITS'
3968       include 'COMMON.NAMES'
3969       include 'COMMON.FFIELD'
3970       include 'COMMON.CONTROL'
3971       logical energy_dec /.false./
3972       double precision u(3),ud(3)
3973       estr=0.0d0
3974       estr1=0.0d0
3975       do i=nnt+1,nct
3976         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3977 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3978 C          do j=1,3
3979 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3980 C     &      *dc(j,i-1)/vbld(i)
3981 C          enddo
3982 C          if (energy_dec) write(iout,*)
3983 C     &       "estr1",i,vbld(i),distchainmax,
3984 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
3985 C        else
3986          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3987         diff = vbld(i)-vbldpDUM
3988          else
3989           diff = vbld(i)-vbldp0
3990 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3991          endif
3992           estr=estr+diff*diff
3993           do j=1,3
3994             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3995           enddo
3996 C        endif
3997 C        write (iout,'(a7,i5,4f7.3)')
3998 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
3999       enddo
4000       estr=0.5d0*AKP*estr+estr1
4001 c
4002 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4003 c
4004       do i=nnt,nct
4005         iti=iabs(itype(i))
4006         if (iti.ne.10 .and. iti.ne.ntyp1) then
4007           nbi=nbondterm(iti)
4008           if (nbi.eq.1) then
4009             diff=vbld(i+nres)-vbldsc0(1,iti)
4010 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4011 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4012             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4013             do j=1,3
4014               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4015             enddo
4016           else
4017             do j=1,nbi
4018               diff=vbld(i+nres)-vbldsc0(j,iti)
4019               ud(j)=aksc(j,iti)*diff
4020               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4021             enddo
4022             uprod=u(1)
4023             do j=2,nbi
4024               uprod=uprod*u(j)
4025             enddo
4026             usum=0.0d0
4027             usumsqder=0.0d0
4028             do j=1,nbi
4029               uprod1=1.0d0
4030               uprod2=1.0d0
4031               do k=1,nbi
4032                 if (k.ne.j) then
4033                   uprod1=uprod1*u(k)
4034                   uprod2=uprod2*u(k)*u(k)
4035                 endif
4036               enddo
4037               usum=usum+uprod1
4038               usumsqder=usumsqder+ud(j)*uprod2
4039             enddo
4040 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4041 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4042             estr=estr+uprod/usum
4043             do j=1,3
4044              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4045             enddo
4046           endif
4047         endif
4048       enddo
4049       return
4050       end
4051 #ifdef CRYST_THETA
4052 C--------------------------------------------------------------------------
4053       subroutine ebend(etheta,ethetacnstr)
4054 C
4055 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4056 C angles gamma and its derivatives in consecutive thetas and gammas.
4057 C
4058       implicit real*8 (a-h,o-z)
4059       include 'DIMENSIONS'
4060       include 'sizesclu.dat'
4061       include 'COMMON.LOCAL'
4062       include 'COMMON.GEO'
4063       include 'COMMON.INTERACT'
4064       include 'COMMON.DERIV'
4065       include 'COMMON.VAR'
4066       include 'COMMON.CHAIN'
4067       include 'COMMON.IOUNITS'
4068       include 'COMMON.NAMES'
4069       include 'COMMON.FFIELD'
4070       include 'COMMON.TORCNSTR'
4071       common /calcthet/ term1,term2,termm,diffak,ratak,
4072      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4073      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4074       double precision y(2),z(2)
4075       delta=0.02d0*pi
4076 c      time11=dexp(-2*time)
4077 c      time12=1.0d0
4078       etheta=0.0D0
4079 c      write (iout,*) "nres",nres
4080 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4081 c      write (iout,*) ithet_start,ithet_end
4082       do i=ithet_start,ithet_end
4083         if (i.le.2) cycle
4084         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4085      &  .or.itype(i).eq.ntyp1) cycle
4086 C Zero the energy function and its derivative at 0 or pi.
4087         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4088         it=itype(i-1)
4089         ichir1=isign(1,itype(i-2))
4090         ichir2=isign(1,itype(i))
4091          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4092          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4093          if (itype(i-1).eq.10) then
4094           itype1=isign(10,itype(i-2))
4095           ichir11=isign(1,itype(i-2))
4096           ichir12=isign(1,itype(i-2))
4097           itype2=isign(10,itype(i))
4098           ichir21=isign(1,itype(i))
4099           ichir22=isign(1,itype(i))
4100          endif
4101          if (i.eq.3) then
4102           y(1)=0.0D0
4103           y(2)=0.0D0
4104           else
4105         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4106 #ifdef OSF
4107           phii=phi(i)
4108 c          icrc=0
4109 c          call proc_proc(phii,icrc)
4110           if (icrc.eq.1) phii=150.0
4111 #else
4112           phii=phi(i)
4113 #endif
4114           y(1)=dcos(phii)
4115           y(2)=dsin(phii)
4116         else
4117           y(1)=0.0D0
4118           y(2)=0.0D0
4119         endif
4120         endif
4121         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4122 #ifdef OSF
4123           phii1=phi(i+1)
4124 c          icrc=0
4125 c          call proc_proc(phii1,icrc)
4126           if (icrc.eq.1) phii1=150.0
4127           phii1=pinorm(phii1)
4128           z(1)=cos(phii1)
4129 #else
4130           phii1=phi(i+1)
4131           z(1)=dcos(phii1)
4132 #endif
4133           z(2)=dsin(phii1)
4134         else
4135           z(1)=0.0D0
4136           z(2)=0.0D0
4137         endif
4138 C Calculate the "mean" value of theta from the part of the distribution
4139 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4140 C In following comments this theta will be referred to as t_c.
4141         thet_pred_mean=0.0d0
4142         do k=1,2
4143             athetk=athet(k,it,ichir1,ichir2)
4144             bthetk=bthet(k,it,ichir1,ichir2)
4145           if (it.eq.10) then
4146              athetk=athet(k,itype1,ichir11,ichir12)
4147              bthetk=bthet(k,itype2,ichir21,ichir22)
4148           endif
4149           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4150         enddo
4151 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4152         dthett=thet_pred_mean*ssd
4153         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4154 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4155 C Derivatives of the "mean" values in gamma1 and gamma2.
4156         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4157      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4158          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4159      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4160          if (it.eq.10) then
4161       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4162      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4163         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4164      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4165          endif
4166         if (theta(i).gt.pi-delta) then
4167           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4168      &         E_tc0)
4169           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4170           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4171           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4172      &        E_theta)
4173           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4174      &        E_tc)
4175         else if (theta(i).lt.delta) then
4176           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4177           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4178           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4179      &        E_theta)
4180           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4181           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4182      &        E_tc)
4183         else
4184           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4185      &        E_theta,E_tc)
4186         endif
4187         etheta=etheta+ethetai
4188 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4189 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4190         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4191         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4192         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4193 c 1215   continue
4194       enddo
4195 C Ufff.... We've done all this!!!
4196 C now constrains
4197       ethetacnstr=0.0d0
4198 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4199       do i=1,ntheta_constr
4200         itheta=itheta_constr(i)
4201         thetiii=theta(itheta)
4202         difi=pinorm(thetiii-theta_constr0(i))
4203         if (difi.gt.theta_drange(i)) then
4204           difi=difi-theta_drange(i)
4205           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4206           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4207      &    +for_thet_constr(i)*difi**3
4208         else if (difi.lt.-drange(i)) then
4209           difi=difi+drange(i)
4210           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4211           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4212      &    +for_thet_constr(i)*difi**3
4213         else
4214           difi=0.0
4215         endif
4216 C       if (energy_dec) then
4217 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4218 C     &    i,itheta,rad2deg*thetiii,
4219 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4220 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4221 C     &    gloc(itheta+nphi-2,icg)
4222 C        endif
4223       enddo
4224       return
4225       end
4226 C---------------------------------------------------------------------------
4227       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4228      &     E_tc)
4229       implicit real*8 (a-h,o-z)
4230       include 'DIMENSIONS'
4231       include 'COMMON.LOCAL'
4232       include 'COMMON.IOUNITS'
4233       common /calcthet/ term1,term2,termm,diffak,ratak,
4234      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4235      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4236 C Calculate the contributions to both Gaussian lobes.
4237 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4238 C The "polynomial part" of the "standard deviation" of this part of
4239 C the distribution.
4240         sig=polthet(3,it)
4241         do j=2,0,-1
4242           sig=sig*thet_pred_mean+polthet(j,it)
4243         enddo
4244 C Derivative of the "interior part" of the "standard deviation of the"
4245 C gamma-dependent Gaussian lobe in t_c.
4246         sigtc=3*polthet(3,it)
4247         do j=2,1,-1
4248           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4249         enddo
4250         sigtc=sig*sigtc
4251 C Set the parameters of both Gaussian lobes of the distribution.
4252 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4253         fac=sig*sig+sigc0(it)
4254         sigcsq=fac+fac
4255         sigc=1.0D0/sigcsq
4256 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4257         sigsqtc=-4.0D0*sigcsq*sigtc
4258 c       print *,i,sig,sigtc,sigsqtc
4259 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4260         sigtc=-sigtc/(fac*fac)
4261 C Following variable is sigma(t_c)**(-2)
4262         sigcsq=sigcsq*sigcsq
4263         sig0i=sig0(it)
4264         sig0inv=1.0D0/sig0i**2
4265         delthec=thetai-thet_pred_mean
4266         delthe0=thetai-theta0i
4267         term1=-0.5D0*sigcsq*delthec*delthec
4268         term2=-0.5D0*sig0inv*delthe0*delthe0
4269 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4270 C NaNs in taking the logarithm. We extract the largest exponent which is added
4271 C to the energy (this being the log of the distribution) at the end of energy
4272 C term evaluation for this virtual-bond angle.
4273         if (term1.gt.term2) then
4274           termm=term1
4275           term2=dexp(term2-termm)
4276           term1=1.0d0
4277         else
4278           termm=term2
4279           term1=dexp(term1-termm)
4280           term2=1.0d0
4281         endif
4282 C The ratio between the gamma-independent and gamma-dependent lobes of
4283 C the distribution is a Gaussian function of thet_pred_mean too.
4284         diffak=gthet(2,it)-thet_pred_mean
4285         ratak=diffak/gthet(3,it)**2
4286         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4287 C Let's differentiate it in thet_pred_mean NOW.
4288         aktc=ak*ratak
4289 C Now put together the distribution terms to make complete distribution.
4290         termexp=term1+ak*term2
4291         termpre=sigc+ak*sig0i
4292 C Contribution of the bending energy from this theta is just the -log of
4293 C the sum of the contributions from the two lobes and the pre-exponential
4294 C factor. Simple enough, isn't it?
4295         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4296 C NOW the derivatives!!!
4297 C 6/6/97 Take into account the deformation.
4298         E_theta=(delthec*sigcsq*term1
4299      &       +ak*delthe0*sig0inv*term2)/termexp
4300         E_tc=((sigtc+aktc*sig0i)/termpre
4301      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4302      &       aktc*term2)/termexp)
4303       return
4304       end
4305 c-----------------------------------------------------------------------------
4306       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4307       implicit real*8 (a-h,o-z)
4308       include 'DIMENSIONS'
4309       include 'COMMON.LOCAL'
4310       include 'COMMON.IOUNITS'
4311       common /calcthet/ term1,term2,termm,diffak,ratak,
4312      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4313      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4314       delthec=thetai-thet_pred_mean
4315       delthe0=thetai-theta0i
4316 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4317       t3 = thetai-thet_pred_mean
4318       t6 = t3**2
4319       t9 = term1
4320       t12 = t3*sigcsq
4321       t14 = t12+t6*sigsqtc
4322       t16 = 1.0d0
4323       t21 = thetai-theta0i
4324       t23 = t21**2
4325       t26 = term2
4326       t27 = t21*t26
4327       t32 = termexp
4328       t40 = t32**2
4329       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4330      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4331      & *(-t12*t9-ak*sig0inv*t27)
4332       return
4333       end
4334 #else
4335 C--------------------------------------------------------------------------
4336       subroutine ebend(etheta,ethetacnstr)
4337 C
4338 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4339 C angles gamma and its derivatives in consecutive thetas and gammas.
4340 C ab initio-derived potentials from
4341 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4342 C
4343       implicit real*8 (a-h,o-z)
4344       include 'DIMENSIONS'
4345       include 'sizesclu.dat'
4346       include 'COMMON.LOCAL'
4347       include 'COMMON.GEO'
4348       include 'COMMON.INTERACT'
4349       include 'COMMON.DERIV'
4350       include 'COMMON.VAR'
4351       include 'COMMON.CHAIN'
4352       include 'COMMON.IOUNITS'
4353       include 'COMMON.NAMES'
4354       include 'COMMON.FFIELD'
4355       include 'COMMON.CONTROL'
4356       include 'COMMON.TORCNSTR'
4357       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4358      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4359      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4360      & sinph1ph2(maxdouble,maxdouble)
4361       logical lprn /.false./, lprn1 /.false./
4362       etheta=0.0D0
4363 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4364       do i=ithet_start,ithet_end
4365         if (i.le.2) cycle
4366         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4367      &  .or.itype(i).eq.ntyp1) cycle
4368 c        if (itype(i-1).eq.ntyp1) cycle
4369         if (iabs(itype(i+1)).eq.20) iblock=2
4370         if (iabs(itype(i+1)).ne.20) iblock=1
4371         dethetai=0.0d0
4372         dephii=0.0d0
4373         dephii1=0.0d0
4374         theti2=0.5d0*theta(i)
4375         ityp2=ithetyp((itype(i-1)))
4376         do k=1,nntheterm
4377           coskt(k)=dcos(k*theti2)
4378           sinkt(k)=dsin(k*theti2)
4379         enddo
4380         if (i.eq.3) then
4381           phii=0.0d0
4382           ityp1=nthetyp+1
4383           do k=1,nsingle
4384             cosph1(k)=0.0d0
4385             sinph1(k)=0.0d0
4386           enddo
4387         else
4388         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4389 #ifdef OSF
4390           phii=phi(i)
4391           if (phii.ne.phii) phii=150.0
4392 #else
4393           phii=phi(i)
4394 #endif
4395           ityp1=ithetyp((itype(i-2)))
4396           do k=1,nsingle
4397             cosph1(k)=dcos(k*phii)
4398             sinph1(k)=dsin(k*phii)
4399           enddo
4400         else
4401           phii=0.0d0
4402 c          ityp1=nthetyp+1
4403           do k=1,nsingle
4404             ityp1=ithetyp((itype(i-2)))
4405             cosph1(k)=0.0d0
4406             sinph1(k)=0.0d0
4407           enddo
4408         endif
4409         endif
4410         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4411 #ifdef OSF
4412           phii1=phi(i+1)
4413           if (phii1.ne.phii1) phii1=150.0
4414           phii1=pinorm(phii1)
4415 #else
4416           phii1=phi(i+1)
4417 #endif
4418           ityp3=ithetyp((itype(i)))
4419           do k=1,nsingle
4420             cosph2(k)=dcos(k*phii1)
4421             sinph2(k)=dsin(k*phii1)
4422           enddo
4423         else
4424           phii1=0.0d0
4425 c          ityp3=nthetyp+1
4426           ityp3=ithetyp((itype(i)))
4427           do k=1,nsingle
4428             cosph2(k)=0.0d0
4429             sinph2(k)=0.0d0
4430           enddo
4431         endif
4432 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4433 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4434 c        call flush(iout)
4435         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4436         do k=1,ndouble
4437           do l=1,k-1
4438             ccl=cosph1(l)*cosph2(k-l)
4439             ssl=sinph1(l)*sinph2(k-l)
4440             scl=sinph1(l)*cosph2(k-l)
4441             csl=cosph1(l)*sinph2(k-l)
4442             cosph1ph2(l,k)=ccl-ssl
4443             cosph1ph2(k,l)=ccl+ssl
4444             sinph1ph2(l,k)=scl+csl
4445             sinph1ph2(k,l)=scl-csl
4446           enddo
4447         enddo
4448         if (lprn) then
4449         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4450      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4451         write (iout,*) "coskt and sinkt"
4452         do k=1,nntheterm
4453           write (iout,*) k,coskt(k),sinkt(k)
4454         enddo
4455         endif
4456         do k=1,ntheterm
4457           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4458           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4459      &      *coskt(k)
4460           if (lprn)
4461      &    write (iout,*) "k",k," aathet",
4462      &    aathet(k,ityp1,ityp2,ityp3,iblock),
4463      &     " ethetai",ethetai
4464         enddo
4465         if (lprn) then
4466         write (iout,*) "cosph and sinph"
4467         do k=1,nsingle
4468           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4469         enddo
4470         write (iout,*) "cosph1ph2 and sinph2ph2"
4471         do k=2,ndouble
4472           do l=1,k-1
4473             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4474      &         sinph1ph2(l,k),sinph1ph2(k,l)
4475           enddo
4476         enddo
4477         write(iout,*) "ethetai",ethetai
4478         endif
4479         do m=1,ntheterm2
4480           do k=1,nsingle
4481             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4482      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4483      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4484      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4485             ethetai=ethetai+sinkt(m)*aux
4486             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4487             dephii=dephii+k*sinkt(m)*(
4488      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4489      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4490             dephii1=dephii1+k*sinkt(m)*(
4491      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4492      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4493             if (lprn)
4494      &      write (iout,*) "m",m," k",k," bbthet",
4495      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4496      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4497      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4498      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4499           enddo
4500         enddo
4501         if (lprn)
4502      &  write(iout,*) "ethetai",ethetai
4503         do m=1,ntheterm3
4504           do k=2,ndouble
4505             do l=1,k-1
4506               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4507      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4508      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4509      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4510               ethetai=ethetai+sinkt(m)*aux
4511               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4512               dephii=dephii+l*sinkt(m)*(
4513      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4514      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4515      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4516      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4517               dephii1=dephii1+(k-l)*sinkt(m)*(
4518      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4519      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4520      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4521      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4522               if (lprn) then
4523               write (iout,*) "m",m," k",k," l",l," ffthet",
4524      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4525      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4526      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4527      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4528      &            " ethetai",ethetai
4529               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4530      &            cosph1ph2(k,l)*sinkt(m),
4531      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4532               endif
4533             enddo
4534           enddo
4535         enddo
4536 10      continue
4537         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4538      &   i,theta(i)*rad2deg,phii*rad2deg,
4539      &   phii1*rad2deg,ethetai
4540         etheta=etheta+ethetai
4541         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4542         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4543 c        gloc(nphi+i-2,icg)=wang*dethetai
4544         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4545       enddo
4546 C now constrains
4547       ethetacnstr=0.0d0
4548 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4549       do i=1,ntheta_constr
4550         itheta=itheta_constr(i)
4551         thetiii=theta(itheta)
4552         difi=pinorm(thetiii-theta_constr0(i))
4553         if (difi.gt.theta_drange(i)) then
4554           difi=difi-theta_drange(i)
4555           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4556           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4557      &    +for_thet_constr(i)*difi**3
4558         else if (difi.lt.-drange(i)) then
4559           difi=difi+drange(i)
4560           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4561           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4562      &    +for_thet_constr(i)*difi**3
4563         else
4564           difi=0.0
4565         endif
4566 C       if (energy_dec) then
4567 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4568 C     &    i,itheta,rad2deg*thetiii,
4569 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4570 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4571 C     &    gloc(itheta+nphi-2,icg)
4572 C        endif
4573       enddo
4574       return
4575       end
4576 #endif
4577 #ifdef CRYST_SC
4578 c-----------------------------------------------------------------------------
4579       subroutine esc(escloc)
4580 C Calculate the local energy of a side chain and its derivatives in the
4581 C corresponding virtual-bond valence angles THETA and the spherical angles
4582 C ALPHA and OMEGA.
4583       implicit real*8 (a-h,o-z)
4584       include 'DIMENSIONS'
4585       include 'sizesclu.dat'
4586       include 'COMMON.GEO'
4587       include 'COMMON.LOCAL'
4588       include 'COMMON.VAR'
4589       include 'COMMON.INTERACT'
4590       include 'COMMON.DERIV'
4591       include 'COMMON.CHAIN'
4592       include 'COMMON.IOUNITS'
4593       include 'COMMON.NAMES'
4594       include 'COMMON.FFIELD'
4595       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4596      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4597       common /sccalc/ time11,time12,time112,theti,it,nlobit
4598       delta=0.02d0*pi
4599       escloc=0.0D0
4600 c     write (iout,'(a)') 'ESC'
4601       do i=loc_start,loc_end
4602         it=itype(i)
4603         if (it.eq.ntyp1) cycle
4604         if (it.eq.10) goto 1
4605         nlobit=nlob(iabs(it))
4606 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4607 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4608         theti=theta(i+1)-pipol
4609         x(1)=dtan(theti)
4610         x(2)=alph(i)
4611         x(3)=omeg(i)
4612 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4613
4614         if (x(2).gt.pi-delta) then
4615           xtemp(1)=x(1)
4616           xtemp(2)=pi-delta
4617           xtemp(3)=x(3)
4618           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4619           xtemp(2)=pi
4620           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4621           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4622      &        escloci,dersc(2))
4623           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4624      &        ddersc0(1),dersc(1))
4625           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4626      &        ddersc0(3),dersc(3))
4627           xtemp(2)=pi-delta
4628           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4629           xtemp(2)=pi
4630           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4631           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4632      &            dersc0(2),esclocbi,dersc02)
4633           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4634      &            dersc12,dersc01)
4635           call splinthet(x(2),0.5d0*delta,ss,ssd)
4636           dersc0(1)=dersc01
4637           dersc0(2)=dersc02
4638           dersc0(3)=0.0d0
4639           do k=1,3
4640             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4641           enddo
4642           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4643 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4644 c    &             esclocbi,ss,ssd
4645           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4646 c         escloci=esclocbi
4647 c         write (iout,*) escloci
4648         else if (x(2).lt.delta) then
4649           xtemp(1)=x(1)
4650           xtemp(2)=delta
4651           xtemp(3)=x(3)
4652           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4653           xtemp(2)=0.0d0
4654           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4655           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4656      &        escloci,dersc(2))
4657           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4658      &        ddersc0(1),dersc(1))
4659           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4660      &        ddersc0(3),dersc(3))
4661           xtemp(2)=delta
4662           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4663           xtemp(2)=0.0d0
4664           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4665           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4666      &            dersc0(2),esclocbi,dersc02)
4667           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4668      &            dersc12,dersc01)
4669           dersc0(1)=dersc01
4670           dersc0(2)=dersc02
4671           dersc0(3)=0.0d0
4672           call splinthet(x(2),0.5d0*delta,ss,ssd)
4673           do k=1,3
4674             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4675           enddo
4676           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4677 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4678 c    &             esclocbi,ss,ssd
4679           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4680 c         write (iout,*) escloci
4681         else
4682           call enesc(x,escloci,dersc,ddummy,.false.)
4683         endif
4684
4685         escloc=escloc+escloci
4686 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4687
4688         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4689      &   wscloc*dersc(1)
4690         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4691         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4692     1   continue
4693       enddo
4694       return
4695       end
4696 C---------------------------------------------------------------------------
4697       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4698       implicit real*8 (a-h,o-z)
4699       include 'DIMENSIONS'
4700       include 'COMMON.GEO'
4701       include 'COMMON.LOCAL'
4702       include 'COMMON.IOUNITS'
4703       common /sccalc/ time11,time12,time112,theti,it,nlobit
4704       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4705       double precision contr(maxlob,-1:1)
4706       logical mixed
4707 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4708         escloc_i=0.0D0
4709         do j=1,3
4710           dersc(j)=0.0D0
4711           if (mixed) ddersc(j)=0.0d0
4712         enddo
4713         x3=x(3)
4714
4715 C Because of periodicity of the dependence of the SC energy in omega we have
4716 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4717 C To avoid underflows, first compute & store the exponents.
4718
4719         do iii=-1,1
4720
4721           x(3)=x3+iii*dwapi
4722
4723           do j=1,nlobit
4724             do k=1,3
4725               z(k)=x(k)-censc(k,j,it)
4726             enddo
4727             do k=1,3
4728               Axk=0.0D0
4729               do l=1,3
4730                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4731               enddo
4732               Ax(k,j,iii)=Axk
4733             enddo
4734             expfac=0.0D0
4735             do k=1,3
4736               expfac=expfac+Ax(k,j,iii)*z(k)
4737             enddo
4738             contr(j,iii)=expfac
4739           enddo ! j
4740
4741         enddo ! iii
4742
4743         x(3)=x3
4744 C As in the case of ebend, we want to avoid underflows in exponentiation and
4745 C subsequent NaNs and INFs in energy calculation.
4746 C Find the largest exponent
4747         emin=contr(1,-1)
4748         do iii=-1,1
4749           do j=1,nlobit
4750             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4751           enddo
4752         enddo
4753         emin=0.5D0*emin
4754 cd      print *,'it=',it,' emin=',emin
4755
4756 C Compute the contribution to SC energy and derivatives
4757         do iii=-1,1
4758
4759           do j=1,nlobit
4760             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4761 cd          print *,'j=',j,' expfac=',expfac
4762             escloc_i=escloc_i+expfac
4763             do k=1,3
4764               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4765             enddo
4766             if (mixed) then
4767               do k=1,3,2
4768                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4769      &            +gaussc(k,2,j,it))*expfac
4770               enddo
4771             endif
4772           enddo
4773
4774         enddo ! iii
4775
4776         dersc(1)=dersc(1)/cos(theti)**2
4777         ddersc(1)=ddersc(1)/cos(theti)**2
4778         ddersc(3)=ddersc(3)
4779
4780         escloci=-(dlog(escloc_i)-emin)
4781         do j=1,3
4782           dersc(j)=dersc(j)/escloc_i
4783         enddo
4784         if (mixed) then
4785           do j=1,3,2
4786             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4787           enddo
4788         endif
4789       return
4790       end
4791 C------------------------------------------------------------------------------
4792       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4793       implicit real*8 (a-h,o-z)
4794       include 'DIMENSIONS'
4795       include 'COMMON.GEO'
4796       include 'COMMON.LOCAL'
4797       include 'COMMON.IOUNITS'
4798       common /sccalc/ time11,time12,time112,theti,it,nlobit
4799       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4800       double precision contr(maxlob)
4801       logical mixed
4802
4803       escloc_i=0.0D0
4804
4805       do j=1,3
4806         dersc(j)=0.0D0
4807       enddo
4808
4809       do j=1,nlobit
4810         do k=1,2
4811           z(k)=x(k)-censc(k,j,it)
4812         enddo
4813         z(3)=dwapi
4814         do k=1,3
4815           Axk=0.0D0
4816           do l=1,3
4817             Axk=Axk+gaussc(l,k,j,it)*z(l)
4818           enddo
4819           Ax(k,j)=Axk
4820         enddo
4821         expfac=0.0D0
4822         do k=1,3
4823           expfac=expfac+Ax(k,j)*z(k)
4824         enddo
4825         contr(j)=expfac
4826       enddo ! j
4827
4828 C As in the case of ebend, we want to avoid underflows in exponentiation and
4829 C subsequent NaNs and INFs in energy calculation.
4830 C Find the largest exponent
4831       emin=contr(1)
4832       do j=1,nlobit
4833         if (emin.gt.contr(j)) emin=contr(j)
4834       enddo
4835       emin=0.5D0*emin
4836
4837 C Compute the contribution to SC energy and derivatives
4838
4839       dersc12=0.0d0
4840       do j=1,nlobit
4841         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4842         escloc_i=escloc_i+expfac
4843         do k=1,2
4844           dersc(k)=dersc(k)+Ax(k,j)*expfac
4845         enddo
4846         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4847      &            +gaussc(1,2,j,it))*expfac
4848         dersc(3)=0.0d0
4849       enddo
4850
4851       dersc(1)=dersc(1)/cos(theti)**2
4852       dersc12=dersc12/cos(theti)**2
4853       escloci=-(dlog(escloc_i)-emin)
4854       do j=1,2
4855         dersc(j)=dersc(j)/escloc_i
4856       enddo
4857       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4858       return
4859       end
4860 #else
4861 c----------------------------------------------------------------------------------
4862       subroutine esc(escloc)
4863 C Calculate the local energy of a side chain and its derivatives in the
4864 C corresponding virtual-bond valence angles THETA and the spherical angles
4865 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4866 C added by Urszula Kozlowska. 07/11/2007
4867 C
4868       implicit real*8 (a-h,o-z)
4869       include 'DIMENSIONS'
4870       include 'sizesclu.dat'
4871       include 'COMMON.GEO'
4872       include 'COMMON.LOCAL'
4873       include 'COMMON.VAR'
4874       include 'COMMON.SCROT'
4875       include 'COMMON.INTERACT'
4876       include 'COMMON.DERIV'
4877       include 'COMMON.CHAIN'
4878       include 'COMMON.IOUNITS'
4879       include 'COMMON.NAMES'
4880       include 'COMMON.FFIELD'
4881       include 'COMMON.CONTROL'
4882       include 'COMMON.VECTORS'
4883       double precision x_prime(3),y_prime(3),z_prime(3)
4884      &    , sumene,dsc_i,dp2_i,x(65),
4885      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4886      &    de_dxx,de_dyy,de_dzz,de_dt
4887       double precision s1_t,s1_6_t,s2_t,s2_6_t
4888       double precision
4889      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4890      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4891      & dt_dCi(3),dt_dCi1(3)
4892       common /sccalc/ time11,time12,time112,theti,it,nlobit
4893       delta=0.02d0*pi
4894       escloc=0.0D0
4895       do i=loc_start,loc_end
4896         if (itype(i).eq.ntyp1) cycle
4897         costtab(i+1) =dcos(theta(i+1))
4898         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4899         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4900         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4901         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4902         cosfac=dsqrt(cosfac2)
4903         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4904         sinfac=dsqrt(sinfac2)
4905         it=iabs(itype(i))
4906         if (it.eq.10) goto 1
4907 c
4908 C  Compute the axes of tghe local cartesian coordinates system; store in
4909 c   x_prime, y_prime and z_prime
4910 c
4911         do j=1,3
4912           x_prime(j) = 0.00
4913           y_prime(j) = 0.00
4914           z_prime(j) = 0.00
4915         enddo
4916 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4917 C     &   dc_norm(3,i+nres)
4918         do j = 1,3
4919           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4920           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4921         enddo
4922         do j = 1,3
4923           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4924         enddo
4925 c       write (2,*) "i",i
4926 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4927 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4928 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4929 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4930 c      & " xy",scalar(x_prime(1),y_prime(1)),
4931 c      & " xz",scalar(x_prime(1),z_prime(1)),
4932 c      & " yy",scalar(y_prime(1),y_prime(1)),
4933 c      & " yz",scalar(y_prime(1),z_prime(1)),
4934 c      & " zz",scalar(z_prime(1),z_prime(1))
4935 c
4936 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4937 C to local coordinate system. Store in xx, yy, zz.
4938 c
4939         xx=0.0d0
4940         yy=0.0d0
4941         zz=0.0d0
4942         do j = 1,3
4943           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4944           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4945           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4946         enddo
4947
4948         xxtab(i)=xx
4949         yytab(i)=yy
4950         zztab(i)=zz
4951 C
4952 C Compute the energy of the ith side cbain
4953 C
4954 c        write (2,*) "xx",xx," yy",yy," zz",zz
4955         it=iabs(itype(i))
4956         do j = 1,65
4957           x(j) = sc_parmin(j,it)
4958         enddo
4959 #ifdef CHECK_COORD
4960 Cc diagnostics - remove later
4961         xx1 = dcos(alph(2))
4962         yy1 = dsin(alph(2))*dcos(omeg(2))
4963 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
4964         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4965         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4966      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4967      &    xx1,yy1,zz1
4968 C,"  --- ", xx_w,yy_w,zz_w
4969 c end diagnostics
4970 #endif
4971         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4972      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4973      &   + x(10)*yy*zz
4974         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4975      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4976      & + x(20)*yy*zz
4977         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4978      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4979      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4980      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4981      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4982      &  +x(40)*xx*yy*zz
4983         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4984      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4985      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4986      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4987      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4988      &  +x(60)*xx*yy*zz
4989         dsc_i   = 0.743d0+x(61)
4990         dp2_i   = 1.9d0+x(62)
4991         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4992      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4993         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4994      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4995         s1=(1+x(63))/(0.1d0 + dscp1)
4996         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4997         s2=(1+x(65))/(0.1d0 + dscp2)
4998         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4999         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5000      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5001 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5002 c     &   sumene4,
5003 c     &   dscp1,dscp2,sumene
5004 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5005         escloc = escloc + sumene
5006 c        write (2,*) "escloc",escloc
5007         if (.not. calc_grad) goto 1
5008 #ifdef DEBUG
5009 C
5010 C This section to check the numerical derivatives of the energy of ith side
5011 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5012 C #define DEBUG in the code to turn it on.
5013 C
5014         write (2,*) "sumene               =",sumene
5015         aincr=1.0d-7
5016         xxsave=xx
5017         xx=xx+aincr
5018         write (2,*) xx,yy,zz
5019         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5020         de_dxx_num=(sumenep-sumene)/aincr
5021         xx=xxsave
5022         write (2,*) "xx+ sumene from enesc=",sumenep
5023         yysave=yy
5024         yy=yy+aincr
5025         write (2,*) xx,yy,zz
5026         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5027         de_dyy_num=(sumenep-sumene)/aincr
5028         yy=yysave
5029         write (2,*) "yy+ sumene from enesc=",sumenep
5030         zzsave=zz
5031         zz=zz+aincr
5032         write (2,*) xx,yy,zz
5033         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5034         de_dzz_num=(sumenep-sumene)/aincr
5035         zz=zzsave
5036         write (2,*) "zz+ sumene from enesc=",sumenep
5037         costsave=cost2tab(i+1)
5038         sintsave=sint2tab(i+1)
5039         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5040         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5041         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5042         de_dt_num=(sumenep-sumene)/aincr
5043         write (2,*) " t+ sumene from enesc=",sumenep
5044         cost2tab(i+1)=costsave
5045         sint2tab(i+1)=sintsave
5046 C End of diagnostics section.
5047 #endif
5048 C
5049 C Compute the gradient of esc
5050 C
5051         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5052         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5053         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5054         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5055         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5056         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5057         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5058         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5059         pom1=(sumene3*sint2tab(i+1)+sumene1)
5060      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5061         pom2=(sumene4*cost2tab(i+1)+sumene2)
5062      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5063         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5064         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5065      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5066      &  +x(40)*yy*zz
5067         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5068         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5069      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5070      &  +x(60)*yy*zz
5071         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5072      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5073      &        +(pom1+pom2)*pom_dx
5074 #ifdef DEBUG
5075         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5076 #endif
5077 C
5078         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5079         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5080      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5081      &  +x(40)*xx*zz
5082         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5083         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5084      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5085      &  +x(59)*zz**2 +x(60)*xx*zz
5086         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5087      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5088      &        +(pom1-pom2)*pom_dy
5089 #ifdef DEBUG
5090         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5091 #endif
5092 C
5093         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5094      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5095      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5096      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5097      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5098      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5099      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5100      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5101 #ifdef DEBUG
5102         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5103 #endif
5104 C
5105         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5106      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5107      &  +pom1*pom_dt1+pom2*pom_dt2
5108 #ifdef DEBUG
5109         write(2,*), "de_dt = ", de_dt,de_dt_num
5110 #endif
5111 c
5112 C
5113        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5114        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5115        cosfac2xx=cosfac2*xx
5116        sinfac2yy=sinfac2*yy
5117        do k = 1,3
5118          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5119      &      vbld_inv(i+1)
5120          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5121      &      vbld_inv(i)
5122          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5123          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5124 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5125 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5126 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5127 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5128          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5129          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5130          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5131          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5132          dZZ_Ci1(k)=0.0d0
5133          dZZ_Ci(k)=0.0d0
5134          do j=1,3
5135            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5136      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5137            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5138      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5139          enddo
5140
5141          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5142          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5143          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5144 c
5145          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5146          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5147        enddo
5148
5149        do k=1,3
5150          dXX_Ctab(k,i)=dXX_Ci(k)
5151          dXX_C1tab(k,i)=dXX_Ci1(k)
5152          dYY_Ctab(k,i)=dYY_Ci(k)
5153          dYY_C1tab(k,i)=dYY_Ci1(k)
5154          dZZ_Ctab(k,i)=dZZ_Ci(k)
5155          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5156          dXX_XYZtab(k,i)=dXX_XYZ(k)
5157          dYY_XYZtab(k,i)=dYY_XYZ(k)
5158          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5159        enddo
5160
5161        do k = 1,3
5162 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5163 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5164 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5165 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5166 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5167 c     &    dt_dci(k)
5168 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5169 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5170          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5171      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5172          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5173      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5174          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5175      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5176        enddo
5177 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5178 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5179
5180 C to check gradient call subroutine check_grad
5181
5182     1 continue
5183       enddo
5184       return
5185       end
5186 #endif
5187 c------------------------------------------------------------------------------
5188       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5189 C
5190 C This procedure calculates two-body contact function g(rij) and its derivative:
5191 C
5192 C           eps0ij                                     !       x < -1
5193 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5194 C            0                                         !       x > 1
5195 C
5196 C where x=(rij-r0ij)/delta
5197 C
5198 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5199 C
5200       implicit none
5201       double precision rij,r0ij,eps0ij,fcont,fprimcont
5202       double precision x,x2,x4,delta
5203 c     delta=0.02D0*r0ij
5204 c      delta=0.2D0*r0ij
5205       x=(rij-r0ij)/delta
5206       if (x.lt.-1.0D0) then
5207         fcont=eps0ij
5208         fprimcont=0.0D0
5209       else if (x.le.1.0D0) then
5210         x2=x*x
5211         x4=x2*x2
5212         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5213         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5214       else
5215         fcont=0.0D0
5216         fprimcont=0.0D0
5217       endif
5218       return
5219       end
5220 c------------------------------------------------------------------------------
5221       subroutine splinthet(theti,delta,ss,ssder)
5222       implicit real*8 (a-h,o-z)
5223       include 'DIMENSIONS'
5224       include 'sizesclu.dat'
5225       include 'COMMON.VAR'
5226       include 'COMMON.GEO'
5227       thetup=pi-delta
5228       thetlow=delta
5229       if (theti.gt.pipol) then
5230         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5231       else
5232         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5233         ssder=-ssder
5234       endif
5235       return
5236       end
5237 c------------------------------------------------------------------------------
5238       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5239       implicit none
5240       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5241       double precision ksi,ksi2,ksi3,a1,a2,a3
5242       a1=fprim0*delta/(f1-f0)
5243       a2=3.0d0-2.0d0*a1
5244       a3=a1-2.0d0
5245       ksi=(x-x0)/delta
5246       ksi2=ksi*ksi
5247       ksi3=ksi2*ksi
5248       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5249       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5250       return
5251       end
5252 c------------------------------------------------------------------------------
5253       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5254       implicit none
5255       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5256       double precision ksi,ksi2,ksi3,a1,a2,a3
5257       ksi=(x-x0)/delta
5258       ksi2=ksi*ksi
5259       ksi3=ksi2*ksi
5260       a1=fprim0x*delta
5261       a2=3*(f1x-f0x)-2*fprim0x*delta
5262       a3=fprim0x*delta-2*(f1x-f0x)
5263       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5264       return
5265       end
5266 C-----------------------------------------------------------------------------
5267 #ifdef CRYST_TOR
5268 C-----------------------------------------------------------------------------
5269       subroutine etor(etors,edihcnstr,fact)
5270       implicit real*8 (a-h,o-z)
5271       include 'DIMENSIONS'
5272       include 'sizesclu.dat'
5273       include 'COMMON.VAR'
5274       include 'COMMON.GEO'
5275       include 'COMMON.LOCAL'
5276       include 'COMMON.TORSION'
5277       include 'COMMON.INTERACT'
5278       include 'COMMON.DERIV'
5279       include 'COMMON.CHAIN'
5280       include 'COMMON.NAMES'
5281       include 'COMMON.IOUNITS'
5282       include 'COMMON.FFIELD'
5283       include 'COMMON.TORCNSTR'
5284       logical lprn
5285 C Set lprn=.true. for debugging
5286       lprn=.false.
5287 c      lprn=.true.
5288       etors=0.0D0
5289       do i=iphi_start,iphi_end
5290         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5291      &      .or. itype(i).eq.ntyp1) cycle
5292         itori=itortyp(itype(i-2))
5293         itori1=itortyp(itype(i-1))
5294         phii=phi(i)
5295         gloci=0.0D0
5296 C Proline-Proline pair is a special case...
5297         if (itori.eq.3 .and. itori1.eq.3) then
5298           if (phii.gt.-dwapi3) then
5299             cosphi=dcos(3*phii)
5300             fac=1.0D0/(1.0D0-cosphi)
5301             etorsi=v1(1,3,3)*fac
5302             etorsi=etorsi+etorsi
5303             etors=etors+etorsi-v1(1,3,3)
5304             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5305           endif
5306           do j=1,3
5307             v1ij=v1(j+1,itori,itori1)
5308             v2ij=v2(j+1,itori,itori1)
5309             cosphi=dcos(j*phii)
5310             sinphi=dsin(j*phii)
5311             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5312             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5313           enddo
5314         else
5315           do j=1,nterm_old
5316             v1ij=v1(j,itori,itori1)
5317             v2ij=v2(j,itori,itori1)
5318             cosphi=dcos(j*phii)
5319             sinphi=dsin(j*phii)
5320             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5321             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5322           enddo
5323         endif
5324         if (lprn)
5325      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5326      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5327      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5328         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5329 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5330       enddo
5331 ! 6/20/98 - dihedral angle constraints
5332       edihcnstr=0.0d0
5333       do i=1,ndih_constr
5334         itori=idih_constr(i)
5335         phii=phi(itori)
5336         difi=phii-phi0(i)
5337         if (difi.gt.drange(i)) then
5338           difi=difi-drange(i)
5339           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5340           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5341         else if (difi.lt.-drange(i)) then
5342           difi=difi+drange(i)
5343           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5344           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5345         endif
5346 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5347 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5348       enddo
5349 !      write (iout,*) 'edihcnstr',edihcnstr
5350       return
5351       end
5352 c------------------------------------------------------------------------------
5353 #else
5354       subroutine etor(etors,edihcnstr,fact)
5355       implicit real*8 (a-h,o-z)
5356       include 'DIMENSIONS'
5357       include 'sizesclu.dat'
5358       include 'COMMON.VAR'
5359       include 'COMMON.GEO'
5360       include 'COMMON.LOCAL'
5361       include 'COMMON.TORSION'
5362       include 'COMMON.INTERACT'
5363       include 'COMMON.DERIV'
5364       include 'COMMON.CHAIN'
5365       include 'COMMON.NAMES'
5366       include 'COMMON.IOUNITS'
5367       include 'COMMON.FFIELD'
5368       include 'COMMON.TORCNSTR'
5369       logical lprn
5370 C Set lprn=.true. for debugging
5371       lprn=.false.
5372 c      lprn=.true.
5373       etors=0.0D0
5374       do i=iphi_start,iphi_end
5375         if (i.le.2) cycle
5376         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5377      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5378         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5379          if (iabs(itype(i)).eq.20) then
5380          iblock=2
5381          else
5382          iblock=1
5383          endif
5384         itori=itortyp(itype(i-2))
5385         itori1=itortyp(itype(i-1))
5386         phii=phi(i)
5387         gloci=0.0D0
5388 C Regular cosine and sine terms
5389         do j=1,nterm(itori,itori1,iblock)
5390           v1ij=v1(j,itori,itori1,iblock)
5391           v2ij=v2(j,itori,itori1,iblock)
5392           cosphi=dcos(j*phii)
5393           sinphi=dsin(j*phii)
5394           etors=etors+v1ij*cosphi+v2ij*sinphi
5395           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5396         enddo
5397 C Lorentz terms
5398 C                         v1
5399 C  E = SUM ----------------------------------- - v1
5400 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5401 C
5402         cosphi=dcos(0.5d0*phii)
5403         sinphi=dsin(0.5d0*phii)
5404         do j=1,nlor(itori,itori1,iblock)
5405           vl1ij=vlor1(j,itori,itori1)
5406           vl2ij=vlor2(j,itori,itori1)
5407           vl3ij=vlor3(j,itori,itori1)
5408           pom=vl2ij*cosphi+vl3ij*sinphi
5409           pom1=1.0d0/(pom*pom+1.0d0)
5410           etors=etors+vl1ij*pom1
5411           pom=-pom*pom1*pom1
5412           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5413         enddo
5414 C Subtract the constant term
5415         etors=etors-v0(itori,itori1,iblock)
5416         if (lprn)
5417      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5418      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5419      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5420         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5421 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5422  1215   continue
5423       enddo
5424 ! 6/20/98 - dihedral angle constraints
5425       edihcnstr=0.0d0
5426       do i=1,ndih_constr
5427         itori=idih_constr(i)
5428         phii=phi(itori)
5429         difi=pinorm(phii-phi0(i))
5430         edihi=0.0d0
5431         if (difi.gt.drange(i)) then
5432           difi=difi-drange(i)
5433           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5434           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5435           edihi=0.25d0*ftors(i)*difi**4
5436         else if (difi.lt.-drange(i)) then
5437           difi=difi+drange(i)
5438           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5439           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5440           edihi=0.25d0*ftors(i)*difi**4
5441         else
5442           difi=0.0d0
5443         endif
5444 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5445 c     &    drange(i),edihi
5446 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5447 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5448       enddo
5449 !      write (iout,*) 'edihcnstr',edihcnstr
5450       return
5451       end
5452 c----------------------------------------------------------------------------
5453       subroutine etor_d(etors_d,fact2)
5454 C 6/23/01 Compute double torsional energy
5455       implicit real*8 (a-h,o-z)
5456       include 'DIMENSIONS'
5457       include 'sizesclu.dat'
5458       include 'COMMON.VAR'
5459       include 'COMMON.GEO'
5460       include 'COMMON.LOCAL'
5461       include 'COMMON.TORSION'
5462       include 'COMMON.INTERACT'
5463       include 'COMMON.DERIV'
5464       include 'COMMON.CHAIN'
5465       include 'COMMON.NAMES'
5466       include 'COMMON.IOUNITS'
5467       include 'COMMON.FFIELD'
5468       include 'COMMON.TORCNSTR'
5469       logical lprn
5470 C Set lprn=.true. for debugging
5471       lprn=.false.
5472 c     lprn=.true.
5473       etors_d=0.0D0
5474       do i=iphi_start,iphi_end-1
5475         if (i.le.3) cycle
5476          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5477      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5478      &  (itype(i+1).eq.ntyp1)) cycle
5479         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5480      &     goto 1215
5481         itori=itortyp(itype(i-2))
5482         itori1=itortyp(itype(i-1))
5483         itori2=itortyp(itype(i))
5484         phii=phi(i)
5485         phii1=phi(i+1)
5486         gloci1=0.0D0
5487         gloci2=0.0D0
5488         iblock=1
5489         if (iabs(itype(i+1)).eq.20) iblock=2
5490 C Regular cosine and sine terms
5491        do j=1,ntermd_1(itori,itori1,itori2,iblock)
5492           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5493           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5494           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5495           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5496           cosphi1=dcos(j*phii)
5497           sinphi1=dsin(j*phii)
5498           cosphi2=dcos(j*phii1)
5499           sinphi2=dsin(j*phii1)
5500           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5501      &     v2cij*cosphi2+v2sij*sinphi2
5502           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5503           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5504         enddo
5505         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5506           do l=1,k-1
5507             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5508             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5509             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5510             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5511             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5512             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5513             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5514             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5515             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5516      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5517             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5518      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5519             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5520      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5521           enddo
5522         enddo
5523         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5524         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5525  1215   continue
5526       enddo
5527       return
5528       end
5529 #endif
5530 c------------------------------------------------------------------------------
5531       subroutine eback_sc_corr(esccor)
5532 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5533 c        conformational states; temporarily implemented as differences
5534 c        between UNRES torsional potentials (dependent on three types of
5535 c        residues) and the torsional potentials dependent on all 20 types
5536 c        of residues computed from AM1 energy surfaces of terminally-blocked
5537 c        amino-acid residues.
5538       implicit real*8 (a-h,o-z)
5539       include 'DIMENSIONS'
5540       include 'sizesclu.dat'
5541       include 'COMMON.VAR'
5542       include 'COMMON.GEO'
5543       include 'COMMON.LOCAL'
5544       include 'COMMON.TORSION'
5545       include 'COMMON.SCCOR'
5546       include 'COMMON.INTERACT'
5547       include 'COMMON.DERIV'
5548       include 'COMMON.CHAIN'
5549       include 'COMMON.NAMES'
5550       include 'COMMON.IOUNITS'
5551       include 'COMMON.FFIELD'
5552       include 'COMMON.CONTROL'
5553       logical lprn
5554 C Set lprn=.true. for debugging
5555       lprn=.false.
5556 c      lprn=.true.
5557 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5558       esccor=0.0D0
5559       do i=itau_start,itau_end
5560         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5561         esccor_ii=0.0D0
5562         isccori=isccortyp(itype(i-2))
5563         isccori1=isccortyp(itype(i-1))
5564         phii=phi(i)
5565         do intertyp=1,3 !intertyp
5566 cc Added 09 May 2012 (Adasko)
5567 cc  Intertyp means interaction type of backbone mainchain correlation:
5568 c   1 = SC...Ca...Ca...Ca
5569 c   2 = Ca...Ca...Ca...SC
5570 c   3 = SC...Ca...Ca...SCi
5571         gloci=0.0D0
5572         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5573      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5574      &      (itype(i-1).eq.ntyp1)))
5575      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5576      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5577      &     .or.(itype(i).eq.ntyp1)))
5578      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5579      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5580      &      (itype(i-3).eq.ntyp1)))) cycle
5581         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5582         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5583      & cycle
5584        do j=1,nterm_sccor(isccori,isccori1)
5585           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5586           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5587           cosphi=dcos(j*tauangle(intertyp,i))
5588           sinphi=dsin(j*tauangle(intertyp,i))
5589            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5590 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5591          enddo
5592 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5593 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
5594         if (lprn)
5595      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5596      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5597      &  (v1sccor(j,1,itori,itori1),j=1,6),
5598      &  (v2sccor(j,1,itori,itori1),j=1,6)
5599         gsccor_loc(i-3)=gloci
5600        enddo !intertyp
5601       enddo
5602       return
5603       end
5604 c------------------------------------------------------------------------------
5605       subroutine multibody(ecorr)
5606 C This subroutine calculates multi-body contributions to energy following
5607 C the idea of Skolnick et al. If side chains I and J make a contact and
5608 C at the same time side chains I+1 and J+1 make a contact, an extra
5609 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5610       implicit real*8 (a-h,o-z)
5611       include 'DIMENSIONS'
5612       include 'COMMON.IOUNITS'
5613       include 'COMMON.DERIV'
5614       include 'COMMON.INTERACT'
5615       include 'COMMON.CONTACTS'
5616       double precision gx(3),gx1(3)
5617       logical lprn
5618
5619 C Set lprn=.true. for debugging
5620       lprn=.false.
5621
5622       if (lprn) then
5623         write (iout,'(a)') 'Contact function values:'
5624         do i=nnt,nct-2
5625           write (iout,'(i2,20(1x,i2,f10.5))')
5626      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5627         enddo
5628       endif
5629       ecorr=0.0D0
5630       do i=nnt,nct
5631         do j=1,3
5632           gradcorr(j,i)=0.0D0
5633           gradxorr(j,i)=0.0D0
5634         enddo
5635       enddo
5636       do i=nnt,nct-2
5637
5638         DO ISHIFT = 3,4
5639
5640         i1=i+ishift
5641         num_conti=num_cont(i)
5642         num_conti1=num_cont(i1)
5643         do jj=1,num_conti
5644           j=jcont(jj,i)
5645           do kk=1,num_conti1
5646             j1=jcont(kk,i1)
5647             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5648 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5649 cd   &                   ' ishift=',ishift
5650 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5651 C The system gains extra energy.
5652               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5653             endif   ! j1==j+-ishift
5654           enddo     ! kk
5655         enddo       ! jj
5656
5657         ENDDO ! ISHIFT
5658
5659       enddo         ! i
5660       return
5661       end
5662 c------------------------------------------------------------------------------
5663       double precision function esccorr(i,j,k,l,jj,kk)
5664       implicit real*8 (a-h,o-z)
5665       include 'DIMENSIONS'
5666       include 'COMMON.IOUNITS'
5667       include 'COMMON.DERIV'
5668       include 'COMMON.INTERACT'
5669       include 'COMMON.CONTACTS'
5670       double precision gx(3),gx1(3)
5671       logical lprn
5672       lprn=.false.
5673       eij=facont(jj,i)
5674       ekl=facont(kk,k)
5675 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5676 C Calculate the multi-body contribution to energy.
5677 C Calculate multi-body contributions to the gradient.
5678 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5679 cd   & k,l,(gacont(m,kk,k),m=1,3)
5680       do m=1,3
5681         gx(m) =ekl*gacont(m,jj,i)
5682         gx1(m)=eij*gacont(m,kk,k)
5683         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5684         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5685         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5686         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5687       enddo
5688       do m=i,j-1
5689         do ll=1,3
5690           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5691         enddo
5692       enddo
5693       do m=k,l-1
5694         do ll=1,3
5695           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5696         enddo
5697       enddo
5698       esccorr=-eij*ekl
5699       return
5700       end
5701 c------------------------------------------------------------------------------
5702 #ifdef MPL
5703       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5704       implicit real*8 (a-h,o-z)
5705       include 'DIMENSIONS'
5706       integer dimen1,dimen2,atom,indx
5707       double precision buffer(dimen1,dimen2)
5708       double precision zapas
5709       common /contacts_hb/ zapas(3,20,maxres,7),
5710      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
5711      &         num_cont_hb(maxres),jcont_hb(20,maxres)
5712       num_kont=num_cont_hb(atom)
5713       do i=1,num_kont
5714         do k=1,7
5715           do j=1,3
5716             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5717           enddo ! j
5718         enddo ! k
5719         buffer(i,indx+22)=facont_hb(i,atom)
5720         buffer(i,indx+23)=ees0p(i,atom)
5721         buffer(i,indx+24)=ees0m(i,atom)
5722         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5723       enddo ! i
5724       buffer(1,indx+26)=dfloat(num_kont)
5725       return
5726       end
5727 c------------------------------------------------------------------------------
5728       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5729       implicit real*8 (a-h,o-z)
5730       include 'DIMENSIONS'
5731       integer dimen1,dimen2,atom,indx
5732       double precision buffer(dimen1,dimen2)
5733       double precision zapas
5734       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5735      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5736      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5737       num_kont=buffer(1,indx+26)
5738       num_kont_old=num_cont_hb(atom)
5739       num_cont_hb(atom)=num_kont+num_kont_old
5740       do i=1,num_kont
5741         ii=i+num_kont_old
5742         do k=1,7
5743           do j=1,3
5744             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5745           enddo ! j
5746         enddo ! k
5747         facont_hb(ii,atom)=buffer(i,indx+22)
5748         ees0p(ii,atom)=buffer(i,indx+23)
5749         ees0m(ii,atom)=buffer(i,indx+24)
5750         jcont_hb(ii,atom)=buffer(i,indx+25)
5751       enddo ! i
5752       return
5753       end
5754 c------------------------------------------------------------------------------
5755 #endif
5756       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5757 C This subroutine calculates multi-body contributions to hydrogen-bonding
5758       implicit real*8 (a-h,o-z)
5759       include 'DIMENSIONS'
5760       include 'sizesclu.dat'
5761       include 'COMMON.IOUNITS'
5762 #ifdef MPL
5763       include 'COMMON.INFO'
5764 #endif
5765       include 'COMMON.FFIELD'
5766       include 'COMMON.DERIV'
5767       include 'COMMON.INTERACT'
5768       include 'COMMON.CONTACTS'
5769 #ifdef MPL
5770       parameter (max_cont=maxconts)
5771       parameter (max_dim=2*(8*3+2))
5772       parameter (msglen1=max_cont*max_dim*4)
5773       parameter (msglen2=2*msglen1)
5774       integer source,CorrelType,CorrelID,Error
5775       double precision buffer(max_cont,max_dim)
5776 #endif
5777       double precision gx(3),gx1(3)
5778       logical lprn,ldone
5779
5780 C Set lprn=.true. for debugging
5781       lprn=.false.
5782 #ifdef MPL
5783       n_corr=0
5784       n_corr1=0
5785       if (fgProcs.le.1) goto 30
5786       if (lprn) then
5787         write (iout,'(a)') 'Contact function values:'
5788         do i=nnt,nct-2
5789           write (iout,'(2i3,50(1x,i2,f5.2))')
5790      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5791      &    j=1,num_cont_hb(i))
5792         enddo
5793       endif
5794 C Caution! Following code assumes that electrostatic interactions concerning
5795 C a given atom are split among at most two processors!
5796       CorrelType=477
5797       CorrelID=MyID+1
5798       ldone=.false.
5799       do i=1,max_cont
5800         do j=1,max_dim
5801           buffer(i,j)=0.0D0
5802         enddo
5803       enddo
5804       mm=mod(MyRank,2)
5805 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5806       if (mm) 20,20,10
5807    10 continue
5808 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5809       if (MyRank.gt.0) then
5810 C Send correlation contributions to the preceding processor
5811         msglen=msglen1
5812         nn=num_cont_hb(iatel_s)
5813         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5814 cd      write (iout,*) 'The BUFFER array:'
5815 cd      do i=1,nn
5816 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5817 cd      enddo
5818         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5819           msglen=msglen2
5820             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5821 C Clear the contacts of the atom passed to the neighboring processor
5822         nn=num_cont_hb(iatel_s+1)
5823 cd      do i=1,nn
5824 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5825 cd      enddo
5826             num_cont_hb(iatel_s)=0
5827         endif
5828 cd      write (iout,*) 'Processor ',MyID,MyRank,
5829 cd   & ' is sending correlation contribution to processor',MyID-1,
5830 cd   & ' msglen=',msglen
5831 cd      write (*,*) 'Processor ',MyID,MyRank,
5832 cd   & ' is sending correlation contribution to processor',MyID-1,
5833 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5834         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5835 cd      write (iout,*) 'Processor ',MyID,
5836 cd   & ' has sent correlation contribution to processor',MyID-1,
5837 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5838 cd      write (*,*) 'Processor ',MyID,
5839 cd   & ' has sent correlation contribution to processor',MyID-1,
5840 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5841         msglen=msglen1
5842       endif ! (MyRank.gt.0)
5843       if (ldone) goto 30
5844       ldone=.true.
5845    20 continue
5846 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5847       if (MyRank.lt.fgProcs-1) then
5848 C Receive correlation contributions from the next processor
5849         msglen=msglen1
5850         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5851 cd      write (iout,*) 'Processor',MyID,
5852 cd   & ' is receiving correlation contribution from processor',MyID+1,
5853 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5854 cd      write (*,*) 'Processor',MyID,
5855 cd   & ' is receiving correlation contribution from processor',MyID+1,
5856 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5857         nbytes=-1
5858         do while (nbytes.le.0)
5859           call mp_probe(MyID+1,CorrelType,nbytes)
5860         enddo
5861 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5862         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5863 cd      write (iout,*) 'Processor',MyID,
5864 cd   & ' has received correlation contribution from processor',MyID+1,
5865 cd   & ' msglen=',msglen,' nbytes=',nbytes
5866 cd      write (iout,*) 'The received BUFFER array:'
5867 cd      do i=1,max_cont
5868 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5869 cd      enddo
5870         if (msglen.eq.msglen1) then
5871           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5872         else if (msglen.eq.msglen2)  then
5873           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5874           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5875         else
5876           write (iout,*)
5877      & 'ERROR!!!! message length changed while processing correlations.'
5878           write (*,*)
5879      & 'ERROR!!!! message length changed while processing correlations.'
5880           call mp_stopall(Error)
5881         endif ! msglen.eq.msglen1
5882       endif ! MyRank.lt.fgProcs-1
5883       if (ldone) goto 30
5884       ldone=.true.
5885       goto 10
5886    30 continue
5887 #endif
5888       if (lprn) then
5889         write (iout,'(a)') 'Contact function values:'
5890         do i=nnt,nct-2
5891           write (iout,'(2i3,50(1x,i2,f5.2))')
5892      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5893      &    j=1,num_cont_hb(i))
5894         enddo
5895       endif
5896       ecorr=0.0D0
5897 C Remove the loop below after debugging !!!
5898       do i=nnt,nct
5899         do j=1,3
5900           gradcorr(j,i)=0.0D0
5901           gradxorr(j,i)=0.0D0
5902         enddo
5903       enddo
5904 C Calculate the local-electrostatic correlation terms
5905       do i=iatel_s,iatel_e+1
5906         i1=i+1
5907         num_conti=num_cont_hb(i)
5908         num_conti1=num_cont_hb(i+1)
5909         do jj=1,num_conti
5910           j=jcont_hb(jj,i)
5911           do kk=1,num_conti1
5912             j1=jcont_hb(kk,i1)
5913 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5914 c     &         ' jj=',jj,' kk=',kk
5915             if (j1.eq.j+1 .or. j1.eq.j-1) then
5916 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5917 C The system gains extra energy.
5918               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5919               n_corr=n_corr+1
5920             else if (j1.eq.j) then
5921 C Contacts I-J and I-(J+1) occur simultaneously.
5922 C The system loses extra energy.
5923 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5924             endif
5925           enddo ! kk
5926           do kk=1,num_conti
5927             j1=jcont_hb(kk,i)
5928 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5929 c    &         ' jj=',jj,' kk=',kk
5930             if (j1.eq.j+1) then
5931 C Contacts I-J and (I+1)-J occur simultaneously.
5932 C The system loses extra energy.
5933 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5934             endif ! j1==j+1
5935           enddo ! kk
5936         enddo ! jj
5937       enddo ! i
5938       return
5939       end
5940 c------------------------------------------------------------------------------
5941       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5942      &  n_corr1)
5943 C This subroutine calculates multi-body contributions to hydrogen-bonding
5944       implicit real*8 (a-h,o-z)
5945       include 'DIMENSIONS'
5946       include 'sizesclu.dat'
5947       include 'COMMON.IOUNITS'
5948 #ifdef MPL
5949       include 'COMMON.INFO'
5950 #endif
5951       include 'COMMON.FFIELD'
5952       include 'COMMON.DERIV'
5953       include 'COMMON.INTERACT'
5954       include 'COMMON.CONTACTS'
5955 #ifdef MPL
5956       parameter (max_cont=maxconts)
5957       parameter (max_dim=2*(8*3+2))
5958       parameter (msglen1=max_cont*max_dim*4)
5959       parameter (msglen2=2*msglen1)
5960       integer source,CorrelType,CorrelID,Error
5961       double precision buffer(max_cont,max_dim)
5962 #endif
5963       double precision gx(3),gx1(3)
5964       logical lprn,ldone
5965
5966 C Set lprn=.true. for debugging
5967       lprn=.false.
5968       eturn6=0.0d0
5969 #ifdef MPL
5970       n_corr=0
5971       n_corr1=0
5972       if (fgProcs.le.1) goto 30
5973       if (lprn) then
5974         write (iout,'(a)') 'Contact function values:'
5975         do i=nnt,nct-2
5976           write (iout,'(2i3,50(1x,i2,f5.2))')
5977      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5978      &    j=1,num_cont_hb(i))
5979         enddo
5980       endif
5981 C Caution! Following code assumes that electrostatic interactions concerning
5982 C a given atom are split among at most two processors!
5983       CorrelType=477
5984       CorrelID=MyID+1
5985       ldone=.false.
5986       do i=1,max_cont
5987         do j=1,max_dim
5988           buffer(i,j)=0.0D0
5989         enddo
5990       enddo
5991       mm=mod(MyRank,2)
5992 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5993       if (mm) 20,20,10
5994    10 continue
5995 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5996       if (MyRank.gt.0) then
5997 C Send correlation contributions to the preceding processor
5998         msglen=msglen1
5999         nn=num_cont_hb(iatel_s)
6000         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6001 cd      write (iout,*) 'The BUFFER array:'
6002 cd      do i=1,nn
6003 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6004 cd      enddo
6005         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6006           msglen=msglen2
6007             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6008 C Clear the contacts of the atom passed to the neighboring processor
6009         nn=num_cont_hb(iatel_s+1)
6010 cd      do i=1,nn
6011 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6012 cd      enddo
6013             num_cont_hb(iatel_s)=0
6014         endif
6015 cd      write (iout,*) 'Processor ',MyID,MyRank,
6016 cd   & ' is sending correlation contribution to processor',MyID-1,
6017 cd   & ' msglen=',msglen
6018 cd      write (*,*) 'Processor ',MyID,MyRank,
6019 cd   & ' is sending correlation contribution to processor',MyID-1,
6020 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6021         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6022 cd      write (iout,*) 'Processor ',MyID,
6023 cd   & ' has sent correlation contribution to processor',MyID-1,
6024 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6025 cd      write (*,*) 'Processor ',MyID,
6026 cd   & ' has sent correlation contribution to processor',MyID-1,
6027 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6028         msglen=msglen1
6029       endif ! (MyRank.gt.0)
6030       if (ldone) goto 30
6031       ldone=.true.
6032    20 continue
6033 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6034       if (MyRank.lt.fgProcs-1) then
6035 C Receive correlation contributions from the next processor
6036         msglen=msglen1
6037         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6038 cd      write (iout,*) 'Processor',MyID,
6039 cd   & ' is receiving correlation contribution from processor',MyID+1,
6040 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6041 cd      write (*,*) 'Processor',MyID,
6042 cd   & ' is receiving correlation contribution from processor',MyID+1,
6043 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6044         nbytes=-1
6045         do while (nbytes.le.0)
6046           call mp_probe(MyID+1,CorrelType,nbytes)
6047         enddo
6048 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6049         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6050 cd      write (iout,*) 'Processor',MyID,
6051 cd   & ' has received correlation contribution from processor',MyID+1,
6052 cd   & ' msglen=',msglen,' nbytes=',nbytes
6053 cd      write (iout,*) 'The received BUFFER array:'
6054 cd      do i=1,max_cont
6055 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6056 cd      enddo
6057         if (msglen.eq.msglen1) then
6058           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6059         else if (msglen.eq.msglen2)  then
6060           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6061           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6062         else
6063           write (iout,*)
6064      & 'ERROR!!!! message length changed while processing correlations.'
6065           write (*,*)
6066      & 'ERROR!!!! message length changed while processing correlations.'
6067           call mp_stopall(Error)
6068         endif ! msglen.eq.msglen1
6069       endif ! MyRank.lt.fgProcs-1
6070       if (ldone) goto 30
6071       ldone=.true.
6072       goto 10
6073    30 continue
6074 #endif
6075       if (lprn) then
6076         write (iout,'(a)') 'Contact function values:'
6077         do i=nnt,nct-2
6078           write (iout,'(2i3,50(1x,i2,f5.2))')
6079      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6080      &    j=1,num_cont_hb(i))
6081         enddo
6082       endif
6083       ecorr=0.0D0
6084       ecorr5=0.0d0
6085       ecorr6=0.0d0
6086 C Remove the loop below after debugging !!!
6087       do i=nnt,nct
6088         do j=1,3
6089           gradcorr(j,i)=0.0D0
6090           gradxorr(j,i)=0.0D0
6091         enddo
6092       enddo
6093 C Calculate the dipole-dipole interaction energies
6094       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6095       do i=iatel_s,iatel_e+1
6096         num_conti=num_cont_hb(i)
6097         do jj=1,num_conti
6098           j=jcont_hb(jj,i)
6099           call dipole(i,j,jj)
6100         enddo
6101       enddo
6102       endif
6103 C Calculate the local-electrostatic correlation terms
6104       do i=iatel_s,iatel_e+1
6105         i1=i+1
6106         num_conti=num_cont_hb(i)
6107         num_conti1=num_cont_hb(i+1)
6108         do jj=1,num_conti
6109           j=jcont_hb(jj,i)
6110           do kk=1,num_conti1
6111             j1=jcont_hb(kk,i1)
6112 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6113 c     &         ' jj=',jj,' kk=',kk
6114             if (j1.eq.j+1 .or. j1.eq.j-1) then
6115 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6116 C The system gains extra energy.
6117               n_corr=n_corr+1
6118               sqd1=dsqrt(d_cont(jj,i))
6119               sqd2=dsqrt(d_cont(kk,i1))
6120               sred_geom = sqd1*sqd2
6121               IF (sred_geom.lt.cutoff_corr) THEN
6122                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6123      &            ekont,fprimcont)
6124 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6125 c     &         ' jj=',jj,' kk=',kk
6126                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6127                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6128                 do l=1,3
6129                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6130                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6131                 enddo
6132                 n_corr1=n_corr1+1
6133 cd               write (iout,*) 'sred_geom=',sred_geom,
6134 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6135                 call calc_eello(i,j,i+1,j1,jj,kk)
6136                 if (wcorr4.gt.0.0d0)
6137      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6138                 if (wcorr5.gt.0.0d0)
6139      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6140 c                print *,"wcorr5",ecorr5
6141 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6142 cd                write(2,*)'ijkl',i,j,i+1,j1
6143                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6144      &               .or. wturn6.eq.0.0d0))then
6145 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6146                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6147 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6148 cd     &            'ecorr6=',ecorr6
6149 cd                write (iout,'(4e15.5)') sred_geom,
6150 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6151 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6152 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6153                 else if (wturn6.gt.0.0d0
6154      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6155 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6156                   eturn6=eturn6+eello_turn6(i,jj,kk)
6157 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6158                 endif
6159               ENDIF
6160 1111          continue
6161             else if (j1.eq.j) then
6162 C Contacts I-J and I-(J+1) occur simultaneously.
6163 C The system loses extra energy.
6164 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6165             endif
6166           enddo ! kk
6167           do kk=1,num_conti
6168             j1=jcont_hb(kk,i)
6169 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6170 c    &         ' jj=',jj,' kk=',kk
6171             if (j1.eq.j+1) then
6172 C Contacts I-J and (I+1)-J occur simultaneously.
6173 C The system loses extra energy.
6174 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6175             endif ! j1==j+1
6176           enddo ! kk
6177         enddo ! jj
6178       enddo ! i
6179       return
6180       end
6181 c------------------------------------------------------------------------------
6182       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6183       implicit real*8 (a-h,o-z)
6184       include 'DIMENSIONS'
6185       include 'COMMON.IOUNITS'
6186       include 'COMMON.DERIV'
6187       include 'COMMON.INTERACT'
6188       include 'COMMON.CONTACTS'
6189       include 'COMMON.SHIELD'
6190
6191       double precision gx(3),gx1(3)
6192       logical lprn
6193       lprn=.false.
6194       eij=facont_hb(jj,i)
6195       ekl=facont_hb(kk,k)
6196       ees0pij=ees0p(jj,i)
6197       ees0pkl=ees0p(kk,k)
6198       ees0mij=ees0m(jj,i)
6199       ees0mkl=ees0m(kk,k)
6200       ekont=eij*ekl
6201       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6202 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6203 C Following 4 lines for diagnostics.
6204 cd    ees0pkl=0.0D0
6205 cd    ees0pij=1.0D0
6206 cd    ees0mkl=0.0D0
6207 cd    ees0mij=1.0D0
6208 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6209 c    &   ' and',k,l
6210 c     write (iout,*)'Contacts have occurred for peptide groups',
6211 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6212 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6213 C Calculate the multi-body contribution to energy.
6214       ecorr=ecorr+ekont*ees
6215       if (calc_grad) then
6216 C Calculate multi-body contributions to the gradient.
6217       do ll=1,3
6218         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6219         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6220      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6221      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6222         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6223      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6224      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6225         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6226         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6227      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6228      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6229         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6230      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6231      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6232       enddo
6233       do m=i+1,j-1
6234         do ll=1,3
6235           gradcorr(ll,m)=gradcorr(ll,m)+
6236      &     ees*ekl*gacont_hbr(ll,jj,i)-
6237      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6238      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6239         enddo
6240       enddo
6241       do m=k+1,l-1
6242         do ll=1,3
6243           gradcorr(ll,m)=gradcorr(ll,m)+
6244      &     ees*eij*gacont_hbr(ll,kk,k)-
6245      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6246      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6247         enddo
6248       enddo
6249       if (shield_mode.gt.0) then
6250        j=ees0plist(jj,i)
6251        l=ees0plist(kk,k)
6252 C        print *,i,j,fac_shield(i),fac_shield(j),
6253 C     &fac_shield(k),fac_shield(l)
6254         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6255      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6256           do ilist=1,ishield_list(i)
6257            iresshield=shield_list(ilist,i)
6258            do m=1,3
6259            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6260 C     &      *2.0
6261            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6262      &              rlocshield
6263      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6264             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6265      &+rlocshield
6266            enddo
6267           enddo
6268           do ilist=1,ishield_list(j)
6269            iresshield=shield_list(ilist,j)
6270            do m=1,3
6271            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6272 C     &     *2.0
6273            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6274      &              rlocshield
6275      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6276            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6277      &     +rlocshield
6278            enddo
6279           enddo
6280           do ilist=1,ishield_list(k)
6281            iresshield=shield_list(ilist,k)
6282            do m=1,3
6283            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6284 C     &     *2.0
6285            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6286      &              rlocshield
6287      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6288            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6289      &     +rlocshield
6290            enddo
6291           enddo
6292           do ilist=1,ishield_list(l)
6293            iresshield=shield_list(ilist,l)
6294            do m=1,3
6295            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6296 C     &     *2.0
6297            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6298      &              rlocshield
6299      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6300            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6301      &     +rlocshield
6302            enddo
6303           enddo
6304 C          print *,gshieldx(m,iresshield)
6305           do m=1,3
6306             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6307      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6308             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6309      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6310             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6311      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6312             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6313      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6314
6315             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6316      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6317             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6318      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6319             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6320      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6321             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6322      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6323
6324            enddo
6325       endif
6326       endif
6327       endif
6328       ehbcorr=ekont*ees
6329       return
6330       end
6331 C---------------------------------------------------------------------------
6332       subroutine dipole(i,j,jj)
6333       implicit real*8 (a-h,o-z)
6334       include 'DIMENSIONS'
6335       include 'sizesclu.dat'
6336       include 'COMMON.IOUNITS'
6337       include 'COMMON.CHAIN'
6338       include 'COMMON.FFIELD'
6339       include 'COMMON.DERIV'
6340       include 'COMMON.INTERACT'
6341       include 'COMMON.CONTACTS'
6342       include 'COMMON.TORSION'
6343       include 'COMMON.VAR'
6344       include 'COMMON.GEO'
6345       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6346      &  auxmat(2,2)
6347       iti1 = itortyp(itype(i+1))
6348       if (j.lt.nres-1) then
6349         if (itype(j).le.ntyp) then
6350           itj1 = itortyp(itype(j+1))
6351         else
6352           itj1=ntortyp+1
6353         endif
6354       else
6355         itj1=ntortyp+1
6356       endif
6357       do iii=1,2
6358         dipi(iii,1)=Ub2(iii,i)
6359         dipderi(iii)=Ub2der(iii,i)
6360         dipi(iii,2)=b1(iii,iti1)
6361         dipj(iii,1)=Ub2(iii,j)
6362         dipderj(iii)=Ub2der(iii,j)
6363         dipj(iii,2)=b1(iii,itj1)
6364       enddo
6365       kkk=0
6366       do iii=1,2
6367         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6368         do jjj=1,2
6369           kkk=kkk+1
6370           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6371         enddo
6372       enddo
6373       if (.not.calc_grad) return
6374       do kkk=1,5
6375         do lll=1,3
6376           mmm=0
6377           do iii=1,2
6378             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6379      &        auxvec(1))
6380             do jjj=1,2
6381               mmm=mmm+1
6382               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6383             enddo
6384           enddo
6385         enddo
6386       enddo
6387       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6388       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6389       do iii=1,2
6390         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6391       enddo
6392       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6393       do iii=1,2
6394         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6395       enddo
6396       return
6397       end
6398 C---------------------------------------------------------------------------
6399       subroutine calc_eello(i,j,k,l,jj,kk)
6400 C
6401 C This subroutine computes matrices and vectors needed to calculate
6402 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6403 C
6404       implicit real*8 (a-h,o-z)
6405       include 'DIMENSIONS'
6406       include 'sizesclu.dat'
6407       include 'COMMON.IOUNITS'
6408       include 'COMMON.CHAIN'
6409       include 'COMMON.DERIV'
6410       include 'COMMON.INTERACT'
6411       include 'COMMON.CONTACTS'
6412       include 'COMMON.TORSION'
6413       include 'COMMON.VAR'
6414       include 'COMMON.GEO'
6415       include 'COMMON.FFIELD'
6416       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6417      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6418       logical lprn
6419       common /kutas/ lprn
6420 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6421 cd     & ' jj=',jj,' kk=',kk
6422 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6423       do iii=1,2
6424         do jjj=1,2
6425           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6426           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6427         enddo
6428       enddo
6429       call transpose2(aa1(1,1),aa1t(1,1))
6430       call transpose2(aa2(1,1),aa2t(1,1))
6431       do kkk=1,5
6432         do lll=1,3
6433           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6434      &      aa1tder(1,1,lll,kkk))
6435           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6436      &      aa2tder(1,1,lll,kkk))
6437         enddo
6438       enddo
6439       if (l.eq.j+1) then
6440 C parallel orientation of the two CA-CA-CA frames.
6441 c        if (i.gt.1) then
6442         if (i.gt.1 .and. itype(i).le.ntyp) then
6443           iti=itortyp(itype(i))
6444         else
6445           iti=ntortyp+1
6446         endif
6447         itk1=itortyp(itype(k+1))
6448         itj=itortyp(itype(j))
6449 c        if (l.lt.nres-1) then
6450         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6451           itl1=itortyp(itype(l+1))
6452         else
6453           itl1=ntortyp+1
6454         endif
6455 C A1 kernel(j+1) A2T
6456 cd        do iii=1,2
6457 cd          write (iout,'(3f10.5,5x,3f10.5)')
6458 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6459 cd        enddo
6460         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6461      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6462      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6463 C Following matrices are needed only for 6-th order cumulants
6464         IF (wcorr6.gt.0.0d0) THEN
6465         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6466      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6467      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6468         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6469      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6470      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6471      &   ADtEAderx(1,1,1,1,1,1))
6472         lprn=.false.
6473         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6474      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6475      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6476      &   ADtEA1derx(1,1,1,1,1,1))
6477         ENDIF
6478 C End 6-th order cumulants
6479 cd        lprn=.false.
6480 cd        if (lprn) then
6481 cd        write (2,*) 'In calc_eello6'
6482 cd        do iii=1,2
6483 cd          write (2,*) 'iii=',iii
6484 cd          do kkk=1,5
6485 cd            write (2,*) 'kkk=',kkk
6486 cd            do jjj=1,2
6487 cd              write (2,'(3(2f10.5),5x)')
6488 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6489 cd            enddo
6490 cd          enddo
6491 cd        enddo
6492 cd        endif
6493         call transpose2(EUgder(1,1,k),auxmat(1,1))
6494         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6495         call transpose2(EUg(1,1,k),auxmat(1,1))
6496         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6497         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6498         do iii=1,2
6499           do kkk=1,5
6500             do lll=1,3
6501               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6502      &          EAEAderx(1,1,lll,kkk,iii,1))
6503             enddo
6504           enddo
6505         enddo
6506 C A1T kernel(i+1) A2
6507         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6508      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6509      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6510 C Following matrices are needed only for 6-th order cumulants
6511         IF (wcorr6.gt.0.0d0) THEN
6512         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6513      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6514      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6515         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6516      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6517      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6518      &   ADtEAderx(1,1,1,1,1,2))
6519         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6520      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6521      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6522      &   ADtEA1derx(1,1,1,1,1,2))
6523         ENDIF
6524 C End 6-th order cumulants
6525         call transpose2(EUgder(1,1,l),auxmat(1,1))
6526         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6527         call transpose2(EUg(1,1,l),auxmat(1,1))
6528         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6529         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6530         do iii=1,2
6531           do kkk=1,5
6532             do lll=1,3
6533               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6534      &          EAEAderx(1,1,lll,kkk,iii,2))
6535             enddo
6536           enddo
6537         enddo
6538 C AEAb1 and AEAb2
6539 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6540 C They are needed only when the fifth- or the sixth-order cumulants are
6541 C indluded.
6542         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6543         call transpose2(AEA(1,1,1),auxmat(1,1))
6544         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6545         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6546         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6547         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6548         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6549         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6550         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6551         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6552         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6553         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6554         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6555         call transpose2(AEA(1,1,2),auxmat(1,1))
6556         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6557         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6558         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6559         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6560         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6561         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6562         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6563         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6564         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6565         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6566         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6567 C Calculate the Cartesian derivatives of the vectors.
6568         do iii=1,2
6569           do kkk=1,5
6570             do lll=1,3
6571               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6572               call matvec2(auxmat(1,1),b1(1,iti),
6573      &          AEAb1derx(1,lll,kkk,iii,1,1))
6574               call matvec2(auxmat(1,1),Ub2(1,i),
6575      &          AEAb2derx(1,lll,kkk,iii,1,1))
6576               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6577      &          AEAb1derx(1,lll,kkk,iii,2,1))
6578               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6579      &          AEAb2derx(1,lll,kkk,iii,2,1))
6580               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6581               call matvec2(auxmat(1,1),b1(1,itj),
6582      &          AEAb1derx(1,lll,kkk,iii,1,2))
6583               call matvec2(auxmat(1,1),Ub2(1,j),
6584      &          AEAb2derx(1,lll,kkk,iii,1,2))
6585               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6586      &          AEAb1derx(1,lll,kkk,iii,2,2))
6587               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6588      &          AEAb2derx(1,lll,kkk,iii,2,2))
6589             enddo
6590           enddo
6591         enddo
6592         ENDIF
6593 C End vectors
6594       else
6595 C Antiparallel orientation of the two CA-CA-CA frames.
6596 c        if (i.gt.1) then
6597         if (i.gt.1 .and. itype(i).le.ntyp) then
6598           iti=itortyp(itype(i))
6599         else
6600           iti=ntortyp+1
6601         endif
6602         itk1=itortyp(itype(k+1))
6603         itl=itortyp(itype(l))
6604         itj=itortyp(itype(j))
6605 c        if (j.lt.nres-1) then
6606         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6607           itj1=itortyp(itype(j+1))
6608         else
6609           itj1=ntortyp+1
6610         endif
6611 C A2 kernel(j-1)T A1T
6612         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6613      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6614      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6615 C Following matrices are needed only for 6-th order cumulants
6616         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6617      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6618         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6619      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6620      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6621         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6622      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6623      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6624      &   ADtEAderx(1,1,1,1,1,1))
6625         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6626      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6627      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6628      &   ADtEA1derx(1,1,1,1,1,1))
6629         ENDIF
6630 C End 6-th order cumulants
6631         call transpose2(EUgder(1,1,k),auxmat(1,1))
6632         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6633         call transpose2(EUg(1,1,k),auxmat(1,1))
6634         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6635         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6636         do iii=1,2
6637           do kkk=1,5
6638             do lll=1,3
6639               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6640      &          EAEAderx(1,1,lll,kkk,iii,1))
6641             enddo
6642           enddo
6643         enddo
6644 C A2T kernel(i+1)T A1
6645         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6646      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6647      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6648 C Following matrices are needed only for 6-th order cumulants
6649         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6650      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6651         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6652      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6653      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6654         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6655      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6656      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6657      &   ADtEAderx(1,1,1,1,1,2))
6658         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6659      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6660      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6661      &   ADtEA1derx(1,1,1,1,1,2))
6662         ENDIF
6663 C End 6-th order cumulants
6664         call transpose2(EUgder(1,1,j),auxmat(1,1))
6665         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6666         call transpose2(EUg(1,1,j),auxmat(1,1))
6667         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6668         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6669         do iii=1,2
6670           do kkk=1,5
6671             do lll=1,3
6672               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6673      &          EAEAderx(1,1,lll,kkk,iii,2))
6674             enddo
6675           enddo
6676         enddo
6677 C AEAb1 and AEAb2
6678 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6679 C They are needed only when the fifth- or the sixth-order cumulants are
6680 C indluded.
6681         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6682      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6683         call transpose2(AEA(1,1,1),auxmat(1,1))
6684         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6685         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6686         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6687         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6688         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6689         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6690         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6691         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6692         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6693         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6694         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6695         call transpose2(AEA(1,1,2),auxmat(1,1))
6696         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6697         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6698         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6699         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6700         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6701         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6702         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6703         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6704         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6705         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6706         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6707 C Calculate the Cartesian derivatives of the vectors.
6708         do iii=1,2
6709           do kkk=1,5
6710             do lll=1,3
6711               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6712               call matvec2(auxmat(1,1),b1(1,iti),
6713      &          AEAb1derx(1,lll,kkk,iii,1,1))
6714               call matvec2(auxmat(1,1),Ub2(1,i),
6715      &          AEAb2derx(1,lll,kkk,iii,1,1))
6716               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6717      &          AEAb1derx(1,lll,kkk,iii,2,1))
6718               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6719      &          AEAb2derx(1,lll,kkk,iii,2,1))
6720               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6721               call matvec2(auxmat(1,1),b1(1,itl),
6722      &          AEAb1derx(1,lll,kkk,iii,1,2))
6723               call matvec2(auxmat(1,1),Ub2(1,l),
6724      &          AEAb2derx(1,lll,kkk,iii,1,2))
6725               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6726      &          AEAb1derx(1,lll,kkk,iii,2,2))
6727               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6728      &          AEAb2derx(1,lll,kkk,iii,2,2))
6729             enddo
6730           enddo
6731         enddo
6732         ENDIF
6733 C End vectors
6734       endif
6735       return
6736       end
6737 C---------------------------------------------------------------------------
6738       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6739      &  KK,KKderg,AKA,AKAderg,AKAderx)
6740       implicit none
6741       integer nderg
6742       logical transp
6743       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6744      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6745      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6746       integer iii,kkk,lll
6747       integer jjj,mmm
6748       logical lprn
6749       common /kutas/ lprn
6750       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6751       do iii=1,nderg
6752         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6753      &    AKAderg(1,1,iii))
6754       enddo
6755 cd      if (lprn) write (2,*) 'In kernel'
6756       do kkk=1,5
6757 cd        if (lprn) write (2,*) 'kkk=',kkk
6758         do lll=1,3
6759           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6760      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6761 cd          if (lprn) then
6762 cd            write (2,*) 'lll=',lll
6763 cd            write (2,*) 'iii=1'
6764 cd            do jjj=1,2
6765 cd              write (2,'(3(2f10.5),5x)')
6766 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6767 cd            enddo
6768 cd          endif
6769           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6770      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6771 cd          if (lprn) then
6772 cd            write (2,*) 'lll=',lll
6773 cd            write (2,*) 'iii=2'
6774 cd            do jjj=1,2
6775 cd              write (2,'(3(2f10.5),5x)')
6776 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6777 cd            enddo
6778 cd          endif
6779         enddo
6780       enddo
6781       return
6782       end
6783 C---------------------------------------------------------------------------
6784       double precision function eello4(i,j,k,l,jj,kk)
6785       implicit real*8 (a-h,o-z)
6786       include 'DIMENSIONS'
6787       include 'sizesclu.dat'
6788       include 'COMMON.IOUNITS'
6789       include 'COMMON.CHAIN'
6790       include 'COMMON.DERIV'
6791       include 'COMMON.INTERACT'
6792       include 'COMMON.CONTACTS'
6793       include 'COMMON.TORSION'
6794       include 'COMMON.VAR'
6795       include 'COMMON.GEO'
6796       double precision pizda(2,2),ggg1(3),ggg2(3)
6797 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6798 cd        eello4=0.0d0
6799 cd        return
6800 cd      endif
6801 cd      print *,'eello4:',i,j,k,l,jj,kk
6802 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6803 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6804 cold      eij=facont_hb(jj,i)
6805 cold      ekl=facont_hb(kk,k)
6806 cold      ekont=eij*ekl
6807       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6808       if (calc_grad) then
6809 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6810       gcorr_loc(k-1)=gcorr_loc(k-1)
6811      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6812       if (l.eq.j+1) then
6813         gcorr_loc(l-1)=gcorr_loc(l-1)
6814      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6815       else
6816         gcorr_loc(j-1)=gcorr_loc(j-1)
6817      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6818       endif
6819       do iii=1,2
6820         do kkk=1,5
6821           do lll=1,3
6822             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6823      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6824 cd            derx(lll,kkk,iii)=0.0d0
6825           enddo
6826         enddo
6827       enddo
6828 cd      gcorr_loc(l-1)=0.0d0
6829 cd      gcorr_loc(j-1)=0.0d0
6830 cd      gcorr_loc(k-1)=0.0d0
6831 cd      eel4=1.0d0
6832 cd      write (iout,*)'Contacts have occurred for peptide groups',
6833 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6834 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6835       if (j.lt.nres-1) then
6836         j1=j+1
6837         j2=j-1
6838       else
6839         j1=j-1
6840         j2=j-2
6841       endif
6842       if (l.lt.nres-1) then
6843         l1=l+1
6844         l2=l-1
6845       else
6846         l1=l-1
6847         l2=l-2
6848       endif
6849       do ll=1,3
6850 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6851         ggg1(ll)=eel4*g_contij(ll,1)
6852         ggg2(ll)=eel4*g_contij(ll,2)
6853         ghalf=0.5d0*ggg1(ll)
6854 cd        ghalf=0.0d0
6855         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6856         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6857         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6858         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6859 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6860         ghalf=0.5d0*ggg2(ll)
6861 cd        ghalf=0.0d0
6862         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6863         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6864         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6865         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6866       enddo
6867 cd      goto 1112
6868       do m=i+1,j-1
6869         do ll=1,3
6870 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6871           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6872         enddo
6873       enddo
6874       do m=k+1,l-1
6875         do ll=1,3
6876 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6877           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6878         enddo
6879       enddo
6880 1112  continue
6881       do m=i+2,j2
6882         do ll=1,3
6883           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6884         enddo
6885       enddo
6886       do m=k+2,l2
6887         do ll=1,3
6888           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6889         enddo
6890       enddo
6891 cd      do iii=1,nres-3
6892 cd        write (2,*) iii,gcorr_loc(iii)
6893 cd      enddo
6894       endif
6895       eello4=ekont*eel4
6896 cd      write (2,*) 'ekont',ekont
6897 cd      write (iout,*) 'eello4',ekont*eel4
6898       return
6899       end
6900 C---------------------------------------------------------------------------
6901       double precision function eello5(i,j,k,l,jj,kk)
6902       implicit real*8 (a-h,o-z)
6903       include 'DIMENSIONS'
6904       include 'sizesclu.dat'
6905       include 'COMMON.IOUNITS'
6906       include 'COMMON.CHAIN'
6907       include 'COMMON.DERIV'
6908       include 'COMMON.INTERACT'
6909       include 'COMMON.CONTACTS'
6910       include 'COMMON.TORSION'
6911       include 'COMMON.VAR'
6912       include 'COMMON.GEO'
6913       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6914       double precision ggg1(3),ggg2(3)
6915 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6916 C                                                                              C
6917 C                            Parallel chains                                   C
6918 C                                                                              C
6919 C          o             o                   o             o                   C
6920 C         /l\           / \             \   / \           / \   /              C
6921 C        /   \         /   \             \ /   \         /   \ /               C
6922 C       j| o |l1       | o |              o| o |         | o |o                C
6923 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6924 C      \i/   \         /   \ /             /   \         /   \                 C
6925 C       o    k1             o                                                  C
6926 C         (I)          (II)                (III)          (IV)                 C
6927 C                                                                              C
6928 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6929 C                                                                              C
6930 C                            Antiparallel chains                               C
6931 C                                                                              C
6932 C          o             o                   o             o                   C
6933 C         /j\           / \             \   / \           / \   /              C
6934 C        /   \         /   \             \ /   \         /   \ /               C
6935 C      j1| o |l        | o |              o| o |         | o |o                C
6936 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6937 C      \i/   \         /   \ /             /   \         /   \                 C
6938 C       o     k1            o                                                  C
6939 C         (I)          (II)                (III)          (IV)                 C
6940 C                                                                              C
6941 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6942 C                                                                              C
6943 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6944 C                                                                              C
6945 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6946 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6947 cd        eello5=0.0d0
6948 cd        return
6949 cd      endif
6950 cd      write (iout,*)
6951 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6952 cd     &   ' and',k,l
6953       itk=itortyp(itype(k))
6954       itl=itortyp(itype(l))
6955       itj=itortyp(itype(j))
6956       eello5_1=0.0d0
6957       eello5_2=0.0d0
6958       eello5_3=0.0d0
6959       eello5_4=0.0d0
6960 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6961 cd     &   eel5_3_num,eel5_4_num)
6962       do iii=1,2
6963         do kkk=1,5
6964           do lll=1,3
6965             derx(lll,kkk,iii)=0.0d0
6966           enddo
6967         enddo
6968       enddo
6969 cd      eij=facont_hb(jj,i)
6970 cd      ekl=facont_hb(kk,k)
6971 cd      ekont=eij*ekl
6972 cd      write (iout,*)'Contacts have occurred for peptide groups',
6973 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6974 cd      goto 1111
6975 C Contribution from the graph I.
6976 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6977 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6978       call transpose2(EUg(1,1,k),auxmat(1,1))
6979       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6980       vv(1)=pizda(1,1)-pizda(2,2)
6981       vv(2)=pizda(1,2)+pizda(2,1)
6982       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6983      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6984       if (calc_grad) then
6985 C Explicit gradient in virtual-dihedral angles.
6986       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6987      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6988      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6989       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6990       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6991       vv(1)=pizda(1,1)-pizda(2,2)
6992       vv(2)=pizda(1,2)+pizda(2,1)
6993       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6994      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6995      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6996       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6997       vv(1)=pizda(1,1)-pizda(2,2)
6998       vv(2)=pizda(1,2)+pizda(2,1)
6999       if (l.eq.j+1) then
7000         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7001      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7002      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7003       else
7004         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7005      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7006      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7007       endif
7008 C Cartesian gradient
7009       do iii=1,2
7010         do kkk=1,5
7011           do lll=1,3
7012             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7013      &        pizda(1,1))
7014             vv(1)=pizda(1,1)-pizda(2,2)
7015             vv(2)=pizda(1,2)+pizda(2,1)
7016             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7017      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7018      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7019           enddo
7020         enddo
7021       enddo
7022 c      goto 1112
7023       endif
7024 c1111  continue
7025 C Contribution from graph II
7026       call transpose2(EE(1,1,itk),auxmat(1,1))
7027       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7028       vv(1)=pizda(1,1)+pizda(2,2)
7029       vv(2)=pizda(2,1)-pizda(1,2)
7030       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7031      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7032       if (calc_grad) then
7033 C Explicit gradient in virtual-dihedral angles.
7034       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7035      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7036       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7037       vv(1)=pizda(1,1)+pizda(2,2)
7038       vv(2)=pizda(2,1)-pizda(1,2)
7039       if (l.eq.j+1) then
7040         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7041      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7042      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7043       else
7044         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7045      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7046      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7047       endif
7048 C Cartesian gradient
7049       do iii=1,2
7050         do kkk=1,5
7051           do lll=1,3
7052             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7053      &        pizda(1,1))
7054             vv(1)=pizda(1,1)+pizda(2,2)
7055             vv(2)=pizda(2,1)-pizda(1,2)
7056             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7057      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7058      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7059           enddo
7060         enddo
7061       enddo
7062 cd      goto 1112
7063       endif
7064 cd1111  continue
7065       if (l.eq.j+1) then
7066 cd        goto 1110
7067 C Parallel orientation
7068 C Contribution from graph III
7069         call transpose2(EUg(1,1,l),auxmat(1,1))
7070         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7071         vv(1)=pizda(1,1)-pizda(2,2)
7072         vv(2)=pizda(1,2)+pizda(2,1)
7073         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7074      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7075         if (calc_grad) then
7076 C Explicit gradient in virtual-dihedral angles.
7077         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7078      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7079      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7080         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7081         vv(1)=pizda(1,1)-pizda(2,2)
7082         vv(2)=pizda(1,2)+pizda(2,1)
7083         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7084      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7085      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7086         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7087         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7088         vv(1)=pizda(1,1)-pizda(2,2)
7089         vv(2)=pizda(1,2)+pizda(2,1)
7090         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7091      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7092      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7093 C Cartesian gradient
7094         do iii=1,2
7095           do kkk=1,5
7096             do lll=1,3
7097               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7098      &          pizda(1,1))
7099               vv(1)=pizda(1,1)-pizda(2,2)
7100               vv(2)=pizda(1,2)+pizda(2,1)
7101               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7102      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7103      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7104             enddo
7105           enddo
7106         enddo
7107 cd        goto 1112
7108         endif
7109 C Contribution from graph IV
7110 cd1110    continue
7111         call transpose2(EE(1,1,itl),auxmat(1,1))
7112         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7113         vv(1)=pizda(1,1)+pizda(2,2)
7114         vv(2)=pizda(2,1)-pizda(1,2)
7115         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7116      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7117         if (calc_grad) then
7118 C Explicit gradient in virtual-dihedral angles.
7119         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7120      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7121         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7122         vv(1)=pizda(1,1)+pizda(2,2)
7123         vv(2)=pizda(2,1)-pizda(1,2)
7124         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7125      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7126      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7127 C Cartesian gradient
7128         do iii=1,2
7129           do kkk=1,5
7130             do lll=1,3
7131               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7132      &          pizda(1,1))
7133               vv(1)=pizda(1,1)+pizda(2,2)
7134               vv(2)=pizda(2,1)-pizda(1,2)
7135               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7136      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7137      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7138             enddo
7139           enddo
7140         enddo
7141         endif
7142       else
7143 C Antiparallel orientation
7144 C Contribution from graph III
7145 c        goto 1110
7146         call transpose2(EUg(1,1,j),auxmat(1,1))
7147         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7148         vv(1)=pizda(1,1)-pizda(2,2)
7149         vv(2)=pizda(1,2)+pizda(2,1)
7150         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7151      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7152         if (calc_grad) then
7153 C Explicit gradient in virtual-dihedral angles.
7154         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7155      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7156      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7157         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7158         vv(1)=pizda(1,1)-pizda(2,2)
7159         vv(2)=pizda(1,2)+pizda(2,1)
7160         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7161      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7162      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7163         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7164         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7165         vv(1)=pizda(1,1)-pizda(2,2)
7166         vv(2)=pizda(1,2)+pizda(2,1)
7167         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7168      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7169      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7170 C Cartesian gradient
7171         do iii=1,2
7172           do kkk=1,5
7173             do lll=1,3
7174               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7175      &          pizda(1,1))
7176               vv(1)=pizda(1,1)-pizda(2,2)
7177               vv(2)=pizda(1,2)+pizda(2,1)
7178               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7179      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7180      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7181             enddo
7182           enddo
7183         enddo
7184 cd        goto 1112
7185         endif
7186 C Contribution from graph IV
7187 1110    continue
7188         call transpose2(EE(1,1,itj),auxmat(1,1))
7189         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7190         vv(1)=pizda(1,1)+pizda(2,2)
7191         vv(2)=pizda(2,1)-pizda(1,2)
7192         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7193      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7194         if (calc_grad) then
7195 C Explicit gradient in virtual-dihedral angles.
7196         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7197      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7198         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7199         vv(1)=pizda(1,1)+pizda(2,2)
7200         vv(2)=pizda(2,1)-pizda(1,2)
7201         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7202      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7203      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7204 C Cartesian gradient
7205         do iii=1,2
7206           do kkk=1,5
7207             do lll=1,3
7208               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7209      &          pizda(1,1))
7210               vv(1)=pizda(1,1)+pizda(2,2)
7211               vv(2)=pizda(2,1)-pizda(1,2)
7212               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7213      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7214      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7215             enddo
7216           enddo
7217         enddo
7218       endif
7219       endif
7220 1112  continue
7221       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7222 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7223 cd        write (2,*) 'ijkl',i,j,k,l
7224 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7225 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7226 cd      endif
7227 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7228 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7229 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7230 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7231       if (calc_grad) then
7232       if (j.lt.nres-1) then
7233         j1=j+1
7234         j2=j-1
7235       else
7236         j1=j-1
7237         j2=j-2
7238       endif
7239       if (l.lt.nres-1) then
7240         l1=l+1
7241         l2=l-1
7242       else
7243         l1=l-1
7244         l2=l-2
7245       endif
7246 cd      eij=1.0d0
7247 cd      ekl=1.0d0
7248 cd      ekont=1.0d0
7249 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7250       do ll=1,3
7251         ggg1(ll)=eel5*g_contij(ll,1)
7252         ggg2(ll)=eel5*g_contij(ll,2)
7253 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7254         ghalf=0.5d0*ggg1(ll)
7255 cd        ghalf=0.0d0
7256         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7257         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7258         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7259         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7260 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7261         ghalf=0.5d0*ggg2(ll)
7262 cd        ghalf=0.0d0
7263         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7264         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7265         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7266         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7267       enddo
7268 cd      goto 1112
7269       do m=i+1,j-1
7270         do ll=1,3
7271 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7272           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7273         enddo
7274       enddo
7275       do m=k+1,l-1
7276         do ll=1,3
7277 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7278           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7279         enddo
7280       enddo
7281 c1112  continue
7282       do m=i+2,j2
7283         do ll=1,3
7284           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7285         enddo
7286       enddo
7287       do m=k+2,l2
7288         do ll=1,3
7289           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7290         enddo
7291       enddo
7292 cd      do iii=1,nres-3
7293 cd        write (2,*) iii,g_corr5_loc(iii)
7294 cd      enddo
7295       endif
7296       eello5=ekont*eel5
7297 cd      write (2,*) 'ekont',ekont
7298 cd      write (iout,*) 'eello5',ekont*eel5
7299       return
7300       end
7301 c--------------------------------------------------------------------------
7302       double precision function eello6(i,j,k,l,jj,kk)
7303       implicit real*8 (a-h,o-z)
7304       include 'DIMENSIONS'
7305       include 'sizesclu.dat'
7306       include 'COMMON.IOUNITS'
7307       include 'COMMON.CHAIN'
7308       include 'COMMON.DERIV'
7309       include 'COMMON.INTERACT'
7310       include 'COMMON.CONTACTS'
7311       include 'COMMON.TORSION'
7312       include 'COMMON.VAR'
7313       include 'COMMON.GEO'
7314       include 'COMMON.FFIELD'
7315       double precision ggg1(3),ggg2(3)
7316 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7317 cd        eello6=0.0d0
7318 cd        return
7319 cd      endif
7320 cd      write (iout,*)
7321 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7322 cd     &   ' and',k,l
7323       eello6_1=0.0d0
7324       eello6_2=0.0d0
7325       eello6_3=0.0d0
7326       eello6_4=0.0d0
7327       eello6_5=0.0d0
7328       eello6_6=0.0d0
7329 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7330 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7331       do iii=1,2
7332         do kkk=1,5
7333           do lll=1,3
7334             derx(lll,kkk,iii)=0.0d0
7335           enddo
7336         enddo
7337       enddo
7338 cd      eij=facont_hb(jj,i)
7339 cd      ekl=facont_hb(kk,k)
7340 cd      ekont=eij*ekl
7341 cd      eij=1.0d0
7342 cd      ekl=1.0d0
7343 cd      ekont=1.0d0
7344       if (l.eq.j+1) then
7345         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7346         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7347         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7348         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7349         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7350         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7351       else
7352         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7353         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7354         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7355         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7356         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7357           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7358         else
7359           eello6_5=0.0d0
7360         endif
7361         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7362       endif
7363 C If turn contributions are considered, they will be handled separately.
7364       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7365 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7366 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7367 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7368 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7369 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7370 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7371 cd      goto 1112
7372       if (calc_grad) then
7373       if (j.lt.nres-1) then
7374         j1=j+1
7375         j2=j-1
7376       else
7377         j1=j-1
7378         j2=j-2
7379       endif
7380       if (l.lt.nres-1) then
7381         l1=l+1
7382         l2=l-1
7383       else
7384         l1=l-1
7385         l2=l-2
7386       endif
7387       do ll=1,3
7388         ggg1(ll)=eel6*g_contij(ll,1)
7389         ggg2(ll)=eel6*g_contij(ll,2)
7390 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7391         ghalf=0.5d0*ggg1(ll)
7392 cd        ghalf=0.0d0
7393         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7394         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7395         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7396         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7397         ghalf=0.5d0*ggg2(ll)
7398 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7399 cd        ghalf=0.0d0
7400         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7401         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7402         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7403         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7404       enddo
7405 cd      goto 1112
7406       do m=i+1,j-1
7407         do ll=1,3
7408 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7409           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7410         enddo
7411       enddo
7412       do m=k+1,l-1
7413         do ll=1,3
7414 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7415           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7416         enddo
7417       enddo
7418 1112  continue
7419       do m=i+2,j2
7420         do ll=1,3
7421           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7422         enddo
7423       enddo
7424       do m=k+2,l2
7425         do ll=1,3
7426           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7427         enddo
7428       enddo
7429 cd      do iii=1,nres-3
7430 cd        write (2,*) iii,g_corr6_loc(iii)
7431 cd      enddo
7432       endif
7433       eello6=ekont*eel6
7434 cd      write (2,*) 'ekont',ekont
7435 cd      write (iout,*) 'eello6',ekont*eel6
7436       return
7437       end
7438 c--------------------------------------------------------------------------
7439       double precision function eello6_graph1(i,j,k,l,imat,swap)
7440       implicit real*8 (a-h,o-z)
7441       include 'DIMENSIONS'
7442       include 'sizesclu.dat'
7443       include 'COMMON.IOUNITS'
7444       include 'COMMON.CHAIN'
7445       include 'COMMON.DERIV'
7446       include 'COMMON.INTERACT'
7447       include 'COMMON.CONTACTS'
7448       include 'COMMON.TORSION'
7449       include 'COMMON.VAR'
7450       include 'COMMON.GEO'
7451       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7452       logical swap
7453       logical lprn
7454       common /kutas/ lprn
7455 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7456 C                                                                              C
7457 C      Parallel       Antiparallel                                             C
7458 C                                                                              C
7459 C          o             o                                                     C
7460 C         /l\           /j\                                                    C
7461 C        /   \         /   \                                                   C
7462 C       /| o |         | o |\                                                  C
7463 C     \ j|/k\|  /   \  |/k\|l /                                                C
7464 C      \ /   \ /     \ /   \ /                                                 C
7465 C       o     o       o     o                                                  C
7466 C       i             i                                                        C
7467 C                                                                              C
7468 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7469       itk=itortyp(itype(k))
7470       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7471       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7472       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7473       call transpose2(EUgC(1,1,k),auxmat(1,1))
7474       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7475       vv1(1)=pizda1(1,1)-pizda1(2,2)
7476       vv1(2)=pizda1(1,2)+pizda1(2,1)
7477       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7478       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7479       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7480       s5=scalar2(vv(1),Dtobr2(1,i))
7481 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7482       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7483       if (.not. calc_grad) return
7484       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7485      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7486      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7487      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7488      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7489      & +scalar2(vv(1),Dtobr2der(1,i)))
7490       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7491       vv1(1)=pizda1(1,1)-pizda1(2,2)
7492       vv1(2)=pizda1(1,2)+pizda1(2,1)
7493       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7494       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7495       if (l.eq.j+1) then
7496         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7497      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7498      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7499      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7500      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7501       else
7502         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7503      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7504      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7505      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7506      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7507       endif
7508       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7509       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7510       vv1(1)=pizda1(1,1)-pizda1(2,2)
7511       vv1(2)=pizda1(1,2)+pizda1(2,1)
7512       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7513      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7514      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7515      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7516       do iii=1,2
7517         if (swap) then
7518           ind=3-iii
7519         else
7520           ind=iii
7521         endif
7522         do kkk=1,5
7523           do lll=1,3
7524             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7525             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7526             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7527             call transpose2(EUgC(1,1,k),auxmat(1,1))
7528             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7529      &        pizda1(1,1))
7530             vv1(1)=pizda1(1,1)-pizda1(2,2)
7531             vv1(2)=pizda1(1,2)+pizda1(2,1)
7532             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7533             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7534      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7535             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7536      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7537             s5=scalar2(vv(1),Dtobr2(1,i))
7538             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7539           enddo
7540         enddo
7541       enddo
7542       return
7543       end
7544 c----------------------------------------------------------------------------
7545       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7546       implicit real*8 (a-h,o-z)
7547       include 'DIMENSIONS'
7548       include 'sizesclu.dat'
7549       include 'COMMON.IOUNITS'
7550       include 'COMMON.CHAIN'
7551       include 'COMMON.DERIV'
7552       include 'COMMON.INTERACT'
7553       include 'COMMON.CONTACTS'
7554       include 'COMMON.TORSION'
7555       include 'COMMON.VAR'
7556       include 'COMMON.GEO'
7557       logical swap
7558       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7559      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7560       logical lprn
7561       common /kutas/ lprn
7562 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7563 C                                                                              C
7564 C      Parallel       Antiparallel                                             C
7565 C                                                                              C
7566 C          o             o                                                     C
7567 C     \   /l\           /j\   /                                                C
7568 C      \ /   \         /   \ /                                                 C
7569 C       o| o |         | o |o                                                  C
7570 C     \ j|/k\|      \  |/k\|l                                                  C
7571 C      \ /   \       \ /   \                                                   C
7572 C       o             o                                                        C
7573 C       i             i                                                        C
7574 C                                                                              C
7575 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7576 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7577 C AL 7/4/01 s1 would occur in the sixth-order moment,
7578 C           but not in a cluster cumulant
7579 #ifdef MOMENT
7580       s1=dip(1,jj,i)*dip(1,kk,k)
7581 #endif
7582       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7583       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7584       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7585       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7586       call transpose2(EUg(1,1,k),auxmat(1,1))
7587       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7588       vv(1)=pizda(1,1)-pizda(2,2)
7589       vv(2)=pizda(1,2)+pizda(2,1)
7590       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7591 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7592 #ifdef MOMENT
7593       eello6_graph2=-(s1+s2+s3+s4)
7594 #else
7595       eello6_graph2=-(s2+s3+s4)
7596 #endif
7597 c      eello6_graph2=-s3
7598       if (.not. calc_grad) return
7599 C Derivatives in gamma(i-1)
7600       if (i.gt.1) then
7601 #ifdef MOMENT
7602         s1=dipderg(1,jj,i)*dip(1,kk,k)
7603 #endif
7604         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7605         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7606         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7607         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7608 #ifdef MOMENT
7609         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7610 #else
7611         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7612 #endif
7613 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7614       endif
7615 C Derivatives in gamma(k-1)
7616 #ifdef MOMENT
7617       s1=dip(1,jj,i)*dipderg(1,kk,k)
7618 #endif
7619       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7620       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7621       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7622       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7623       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7624       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7625       vv(1)=pizda(1,1)-pizda(2,2)
7626       vv(2)=pizda(1,2)+pizda(2,1)
7627       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7628 #ifdef MOMENT
7629       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7630 #else
7631       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7632 #endif
7633 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7634 C Derivatives in gamma(j-1) or gamma(l-1)
7635       if (j.gt.1) then
7636 #ifdef MOMENT
7637         s1=dipderg(3,jj,i)*dip(1,kk,k)
7638 #endif
7639         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7640         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7641         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7642         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7643         vv(1)=pizda(1,1)-pizda(2,2)
7644         vv(2)=pizda(1,2)+pizda(2,1)
7645         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7646 #ifdef MOMENT
7647         if (swap) then
7648           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7649         else
7650           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7651         endif
7652 #endif
7653         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7654 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7655       endif
7656 C Derivatives in gamma(l-1) or gamma(j-1)
7657       if (l.gt.1) then
7658 #ifdef MOMENT
7659         s1=dip(1,jj,i)*dipderg(3,kk,k)
7660 #endif
7661         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7662         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7663         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7664         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7665         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7666         vv(1)=pizda(1,1)-pizda(2,2)
7667         vv(2)=pizda(1,2)+pizda(2,1)
7668         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7669 #ifdef MOMENT
7670         if (swap) then
7671           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7672         else
7673           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7674         endif
7675 #endif
7676         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7677 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7678       endif
7679 C Cartesian derivatives.
7680       if (lprn) then
7681         write (2,*) 'In eello6_graph2'
7682         do iii=1,2
7683           write (2,*) 'iii=',iii
7684           do kkk=1,5
7685             write (2,*) 'kkk=',kkk
7686             do jjj=1,2
7687               write (2,'(3(2f10.5),5x)')
7688      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7689             enddo
7690           enddo
7691         enddo
7692       endif
7693       do iii=1,2
7694         do kkk=1,5
7695           do lll=1,3
7696 #ifdef MOMENT
7697             if (iii.eq.1) then
7698               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7699             else
7700               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7701             endif
7702 #endif
7703             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7704      &        auxvec(1))
7705             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7706             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7707      &        auxvec(1))
7708             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7709             call transpose2(EUg(1,1,k),auxmat(1,1))
7710             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7711      &        pizda(1,1))
7712             vv(1)=pizda(1,1)-pizda(2,2)
7713             vv(2)=pizda(1,2)+pizda(2,1)
7714             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7715 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7716 #ifdef MOMENT
7717             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7718 #else
7719             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7720 #endif
7721             if (swap) then
7722               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7723             else
7724               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7725             endif
7726           enddo
7727         enddo
7728       enddo
7729       return
7730       end
7731 c----------------------------------------------------------------------------
7732       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7733       implicit real*8 (a-h,o-z)
7734       include 'DIMENSIONS'
7735       include 'sizesclu.dat'
7736       include 'COMMON.IOUNITS'
7737       include 'COMMON.CHAIN'
7738       include 'COMMON.DERIV'
7739       include 'COMMON.INTERACT'
7740       include 'COMMON.CONTACTS'
7741       include 'COMMON.TORSION'
7742       include 'COMMON.VAR'
7743       include 'COMMON.GEO'
7744       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7745       logical swap
7746 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7747 C                                                                              C
7748 C      Parallel       Antiparallel                                             C
7749 C                                                                              C
7750 C          o             o                                                     C
7751 C         /l\   /   \   /j\                                                    C
7752 C        /   \ /     \ /   \                                                   C
7753 C       /| o |o       o| o |\                                                  C
7754 C       j|/k\|  /      |/k\|l /                                                C
7755 C        /   \ /       /   \ /                                                 C
7756 C       /     o       /     o                                                  C
7757 C       i             i                                                        C
7758 C                                                                              C
7759 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7760 C
7761 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7762 C           energy moment and not to the cluster cumulant.
7763       iti=itortyp(itype(i))
7764 c      if (j.lt.nres-1) then
7765       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7766         itj1=itortyp(itype(j+1))
7767       else
7768         itj1=ntortyp+1
7769       endif
7770       itk=itortyp(itype(k))
7771       itk1=itortyp(itype(k+1))
7772 c      if (l.lt.nres-1) then
7773       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7774         itl1=itortyp(itype(l+1))
7775       else
7776         itl1=ntortyp+1
7777       endif
7778 #ifdef MOMENT
7779       s1=dip(4,jj,i)*dip(4,kk,k)
7780 #endif
7781       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7782       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7783       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7784       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7785       call transpose2(EE(1,1,itk),auxmat(1,1))
7786       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7787       vv(1)=pizda(1,1)+pizda(2,2)
7788       vv(2)=pizda(2,1)-pizda(1,2)
7789       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7790 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7791 #ifdef MOMENT
7792       eello6_graph3=-(s1+s2+s3+s4)
7793 #else
7794       eello6_graph3=-(s2+s3+s4)
7795 #endif
7796 c      eello6_graph3=-s4
7797       if (.not. calc_grad) return
7798 C Derivatives in gamma(k-1)
7799       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7800       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7801       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7802       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7803 C Derivatives in gamma(l-1)
7804       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7805       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7806       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7807       vv(1)=pizda(1,1)+pizda(2,2)
7808       vv(2)=pizda(2,1)-pizda(1,2)
7809       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7810       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7811 C Cartesian derivatives.
7812       do iii=1,2
7813         do kkk=1,5
7814           do lll=1,3
7815 #ifdef MOMENT
7816             if (iii.eq.1) then
7817               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7818             else
7819               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7820             endif
7821 #endif
7822             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7823      &        auxvec(1))
7824             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7825             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7826      &        auxvec(1))
7827             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7828             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7829      &        pizda(1,1))
7830             vv(1)=pizda(1,1)+pizda(2,2)
7831             vv(2)=pizda(2,1)-pizda(1,2)
7832             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7833 #ifdef MOMENT
7834             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7835 #else
7836             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7837 #endif
7838             if (swap) then
7839               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7840             else
7841               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7842             endif
7843 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7844           enddo
7845         enddo
7846       enddo
7847       return
7848       end
7849 c----------------------------------------------------------------------------
7850       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7851       implicit real*8 (a-h,o-z)
7852       include 'DIMENSIONS'
7853       include 'sizesclu.dat'
7854       include 'COMMON.IOUNITS'
7855       include 'COMMON.CHAIN'
7856       include 'COMMON.DERIV'
7857       include 'COMMON.INTERACT'
7858       include 'COMMON.CONTACTS'
7859       include 'COMMON.TORSION'
7860       include 'COMMON.VAR'
7861       include 'COMMON.GEO'
7862       include 'COMMON.FFIELD'
7863       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7864      & auxvec1(2),auxmat1(2,2)
7865       logical swap
7866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7867 C                                                                              C
7868 C      Parallel       Antiparallel                                             C
7869 C                                                                              C
7870 C          o             o                                                     C
7871 C         /l\   /   \   /j\                                                    C
7872 C        /   \ /     \ /   \                                                   C
7873 C       /| o |o       o| o |\                                                  C
7874 C     \ j|/k\|      \  |/k\|l                                                  C
7875 C      \ /   \       \ /   \                                                   C
7876 C       o     \       o     \                                                  C
7877 C       i             i                                                        C
7878 C                                                                              C
7879 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7880 C
7881 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7882 C           energy moment and not to the cluster cumulant.
7883 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7884       iti=itortyp(itype(i))
7885       itj=itortyp(itype(j))
7886 c      if (j.lt.nres-1) then
7887       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7888         itj1=itortyp(itype(j+1))
7889       else
7890         itj1=ntortyp+1
7891       endif
7892       itk=itortyp(itype(k))
7893 c      if (k.lt.nres-1) then
7894       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7895         itk1=itortyp(itype(k+1))
7896       else
7897         itk1=ntortyp+1
7898       endif
7899       itl=itortyp(itype(l))
7900       if (l.lt.nres-1) then
7901         itl1=itortyp(itype(l+1))
7902       else
7903         itl1=ntortyp+1
7904       endif
7905 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7906 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7907 cd     & ' itl',itl,' itl1',itl1
7908 #ifdef MOMENT
7909       if (imat.eq.1) then
7910         s1=dip(3,jj,i)*dip(3,kk,k)
7911       else
7912         s1=dip(2,jj,j)*dip(2,kk,l)
7913       endif
7914 #endif
7915       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7916       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7917       if (j.eq.l+1) then
7918         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7919         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7920       else
7921         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7922         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7923       endif
7924       call transpose2(EUg(1,1,k),auxmat(1,1))
7925       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7926       vv(1)=pizda(1,1)-pizda(2,2)
7927       vv(2)=pizda(2,1)+pizda(1,2)
7928       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7929 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7930 #ifdef MOMENT
7931       eello6_graph4=-(s1+s2+s3+s4)
7932 #else
7933       eello6_graph4=-(s2+s3+s4)
7934 #endif
7935       if (.not. calc_grad) return
7936 C Derivatives in gamma(i-1)
7937       if (i.gt.1) then
7938 #ifdef MOMENT
7939         if (imat.eq.1) then
7940           s1=dipderg(2,jj,i)*dip(3,kk,k)
7941         else
7942           s1=dipderg(4,jj,j)*dip(2,kk,l)
7943         endif
7944 #endif
7945         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7946         if (j.eq.l+1) then
7947           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7948           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7949         else
7950           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7951           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7952         endif
7953         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7954         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7955 cd          write (2,*) 'turn6 derivatives'
7956 #ifdef MOMENT
7957           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7958 #else
7959           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7960 #endif
7961         else
7962 #ifdef MOMENT
7963           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7964 #else
7965           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7966 #endif
7967         endif
7968       endif
7969 C Derivatives in gamma(k-1)
7970 #ifdef MOMENT
7971       if (imat.eq.1) then
7972         s1=dip(3,jj,i)*dipderg(2,kk,k)
7973       else
7974         s1=dip(2,jj,j)*dipderg(4,kk,l)
7975       endif
7976 #endif
7977       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7978       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7979       if (j.eq.l+1) then
7980         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7981         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7982       else
7983         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7984         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7985       endif
7986       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7987       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7988       vv(1)=pizda(1,1)-pizda(2,2)
7989       vv(2)=pizda(2,1)+pizda(1,2)
7990       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7991       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7992 #ifdef MOMENT
7993         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7994 #else
7995         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7996 #endif
7997       else
7998 #ifdef MOMENT
7999         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8000 #else
8001         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8002 #endif
8003       endif
8004 C Derivatives in gamma(j-1) or gamma(l-1)
8005       if (l.eq.j+1 .and. l.gt.1) then
8006         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8007         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8008         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8009         vv(1)=pizda(1,1)-pizda(2,2)
8010         vv(2)=pizda(2,1)+pizda(1,2)
8011         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8012         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8013       else if (j.gt.1) then
8014         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8015         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8016         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8017         vv(1)=pizda(1,1)-pizda(2,2)
8018         vv(2)=pizda(2,1)+pizda(1,2)
8019         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8020         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8021           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8022         else
8023           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8024         endif
8025       endif
8026 C Cartesian derivatives.
8027       do iii=1,2
8028         do kkk=1,5
8029           do lll=1,3
8030 #ifdef MOMENT
8031             if (iii.eq.1) then
8032               if (imat.eq.1) then
8033                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8034               else
8035                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8036               endif
8037             else
8038               if (imat.eq.1) then
8039                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8040               else
8041                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8042               endif
8043             endif
8044 #endif
8045             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8046      &        auxvec(1))
8047             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8048             if (j.eq.l+1) then
8049               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8050      &          b1(1,itj1),auxvec(1))
8051               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8052             else
8053               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8054      &          b1(1,itl1),auxvec(1))
8055               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8056             endif
8057             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8058      &        pizda(1,1))
8059             vv(1)=pizda(1,1)-pizda(2,2)
8060             vv(2)=pizda(2,1)+pizda(1,2)
8061             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8062             if (swap) then
8063               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8064 #ifdef MOMENT
8065                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8066      &             -(s1+s2+s4)
8067 #else
8068                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8069      &             -(s2+s4)
8070 #endif
8071                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8072               else
8073 #ifdef MOMENT
8074                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8075 #else
8076                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8077 #endif
8078                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8079               endif
8080             else
8081 #ifdef MOMENT
8082               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8083 #else
8084               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8085 #endif
8086               if (l.eq.j+1) then
8087                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8088               else
8089                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8090               endif
8091             endif
8092           enddo
8093         enddo
8094       enddo
8095       return
8096       end
8097 c----------------------------------------------------------------------------
8098       double precision function eello_turn6(i,jj,kk)
8099       implicit real*8 (a-h,o-z)
8100       include 'DIMENSIONS'
8101       include 'sizesclu.dat'
8102       include 'COMMON.IOUNITS'
8103       include 'COMMON.CHAIN'
8104       include 'COMMON.DERIV'
8105       include 'COMMON.INTERACT'
8106       include 'COMMON.CONTACTS'
8107       include 'COMMON.TORSION'
8108       include 'COMMON.VAR'
8109       include 'COMMON.GEO'
8110       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8111      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8112      &  ggg1(3),ggg2(3)
8113       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8114      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8115 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8116 C           the respective energy moment and not to the cluster cumulant.
8117       eello_turn6=0.0d0
8118       j=i+4
8119       k=i+1
8120       l=i+3
8121       iti=itortyp(itype(i))
8122       itk=itortyp(itype(k))
8123       itk1=itortyp(itype(k+1))
8124       itl=itortyp(itype(l))
8125       itj=itortyp(itype(j))
8126 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8127 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8128 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8129 cd        eello6=0.0d0
8130 cd        return
8131 cd      endif
8132 cd      write (iout,*)
8133 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8134 cd     &   ' and',k,l
8135 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8136       do iii=1,2
8137         do kkk=1,5
8138           do lll=1,3
8139             derx_turn(lll,kkk,iii)=0.0d0
8140           enddo
8141         enddo
8142       enddo
8143 cd      eij=1.0d0
8144 cd      ekl=1.0d0
8145 cd      ekont=1.0d0
8146       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8147 cd      eello6_5=0.0d0
8148 cd      write (2,*) 'eello6_5',eello6_5
8149 #ifdef MOMENT
8150       call transpose2(AEA(1,1,1),auxmat(1,1))
8151       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8152       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8153       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8154 #else
8155       s1 = 0.0d0
8156 #endif
8157       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8158       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8159       s2 = scalar2(b1(1,itk),vtemp1(1))
8160 #ifdef MOMENT
8161       call transpose2(AEA(1,1,2),atemp(1,1))
8162       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8163       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8164       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8165 #else
8166       s8=0.0d0
8167 #endif
8168       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8169       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8170       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8171 #ifdef MOMENT
8172       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8173       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8174       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8175       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8176       ss13 = scalar2(b1(1,itk),vtemp4(1))
8177       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8178 #else
8179       s13=0.0d0
8180 #endif
8181 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8182 c      s1=0.0d0
8183 c      s2=0.0d0
8184 c      s8=0.0d0
8185 c      s12=0.0d0
8186 c      s13=0.0d0
8187       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8188       if (calc_grad) then
8189 C Derivatives in gamma(i+2)
8190 #ifdef MOMENT
8191       call transpose2(AEA(1,1,1),auxmatd(1,1))
8192       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8193       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8194       call transpose2(AEAderg(1,1,2),atempd(1,1))
8195       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8196       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8197 #else
8198       s8d=0.0d0
8199 #endif
8200       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8201       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8202       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8203 c      s1d=0.0d0
8204 c      s2d=0.0d0
8205 c      s8d=0.0d0
8206 c      s12d=0.0d0
8207 c      s13d=0.0d0
8208       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8209 C Derivatives in gamma(i+3)
8210 #ifdef MOMENT
8211       call transpose2(AEA(1,1,1),auxmatd(1,1))
8212       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8213       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8214       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8215 #else
8216       s1d=0.0d0
8217 #endif
8218       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8219       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8220       s2d = scalar2(b1(1,itk),vtemp1d(1))
8221 #ifdef MOMENT
8222       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8223       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8224 #endif
8225       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8226 #ifdef MOMENT
8227       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8228       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8229       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8230 #else
8231       s13d=0.0d0
8232 #endif
8233 c      s1d=0.0d0
8234 c      s2d=0.0d0
8235 c      s8d=0.0d0
8236 c      s12d=0.0d0
8237 c      s13d=0.0d0
8238 #ifdef MOMENT
8239       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8240      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8241 #else
8242       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8243      &               -0.5d0*ekont*(s2d+s12d)
8244 #endif
8245 C Derivatives in gamma(i+4)
8246       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8247       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8248       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8249 #ifdef MOMENT
8250       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8251       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8252       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8253 #else
8254       s13d = 0.0d0
8255 #endif
8256 c      s1d=0.0d0
8257 c      s2d=0.0d0
8258 c      s8d=0.0d0
8259 C      s12d=0.0d0
8260 c      s13d=0.0d0
8261 #ifdef MOMENT
8262       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8263 #else
8264       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8265 #endif
8266 C Derivatives in gamma(i+5)
8267 #ifdef MOMENT
8268       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8269       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8270       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8271 #else
8272       s1d = 0.0d0
8273 #endif
8274       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8275       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8276       s2d = scalar2(b1(1,itk),vtemp1d(1))
8277 #ifdef MOMENT
8278       call transpose2(AEA(1,1,2),atempd(1,1))
8279       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8280       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8281 #else
8282       s8d = 0.0d0
8283 #endif
8284       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8285       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8286 #ifdef MOMENT
8287       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8288       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8289       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8290 #else
8291       s13d = 0.0d0
8292 #endif
8293 c      s1d=0.0d0
8294 c      s2d=0.0d0
8295 c      s8d=0.0d0
8296 c      s12d=0.0d0
8297 c      s13d=0.0d0
8298 #ifdef MOMENT
8299       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8300      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8301 #else
8302       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8303      &               -0.5d0*ekont*(s2d+s12d)
8304 #endif
8305 C Cartesian derivatives
8306       do iii=1,2
8307         do kkk=1,5
8308           do lll=1,3
8309 #ifdef MOMENT
8310             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8311             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8312             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8313 #else
8314             s1d = 0.0d0
8315 #endif
8316             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8317             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8318      &          vtemp1d(1))
8319             s2d = scalar2(b1(1,itk),vtemp1d(1))
8320 #ifdef MOMENT
8321             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8322             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8323             s8d = -(atempd(1,1)+atempd(2,2))*
8324      &           scalar2(cc(1,1,itl),vtemp2(1))
8325 #else
8326             s8d = 0.0d0
8327 #endif
8328             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8329      &           auxmatd(1,1))
8330             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8331             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8332 c      s1d=0.0d0
8333 c      s2d=0.0d0
8334 c      s8d=0.0d0
8335 c      s12d=0.0d0
8336 c      s13d=0.0d0
8337 #ifdef MOMENT
8338             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8339      &        - 0.5d0*(s1d+s2d)
8340 #else
8341             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8342      &        - 0.5d0*s2d
8343 #endif
8344 #ifdef MOMENT
8345             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8346      &        - 0.5d0*(s8d+s12d)
8347 #else
8348             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8349      &        - 0.5d0*s12d
8350 #endif
8351           enddo
8352         enddo
8353       enddo
8354 #ifdef MOMENT
8355       do kkk=1,5
8356         do lll=1,3
8357           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8358      &      achuj_tempd(1,1))
8359           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8360           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8361           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8362           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8363           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8364      &      vtemp4d(1))
8365           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8366           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8367           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8368         enddo
8369       enddo
8370 #endif
8371 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8372 cd     &  16*eel_turn6_num
8373 cd      goto 1112
8374       if (j.lt.nres-1) then
8375         j1=j+1
8376         j2=j-1
8377       else
8378         j1=j-1
8379         j2=j-2
8380       endif
8381       if (l.lt.nres-1) then
8382         l1=l+1
8383         l2=l-1
8384       else
8385         l1=l-1
8386         l2=l-2
8387       endif
8388       do ll=1,3
8389         ggg1(ll)=eel_turn6*g_contij(ll,1)
8390         ggg2(ll)=eel_turn6*g_contij(ll,2)
8391         ghalf=0.5d0*ggg1(ll)
8392 cd        ghalf=0.0d0
8393         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8394      &    +ekont*derx_turn(ll,2,1)
8395         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8396         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8397      &    +ekont*derx_turn(ll,4,1)
8398         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8399         ghalf=0.5d0*ggg2(ll)
8400 cd        ghalf=0.0d0
8401         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8402      &    +ekont*derx_turn(ll,2,2)
8403         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8404         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8405      &    +ekont*derx_turn(ll,4,2)
8406         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8407       enddo
8408 cd      goto 1112
8409       do m=i+1,j-1
8410         do ll=1,3
8411           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8412         enddo
8413       enddo
8414       do m=k+1,l-1
8415         do ll=1,3
8416           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8417         enddo
8418       enddo
8419 1112  continue
8420       do m=i+2,j2
8421         do ll=1,3
8422           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8423         enddo
8424       enddo
8425       do m=k+2,l2
8426         do ll=1,3
8427           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8428         enddo
8429       enddo
8430 cd      do iii=1,nres-3
8431 cd        write (2,*) iii,g_corr6_loc(iii)
8432 cd      enddo
8433       endif
8434       eello_turn6=ekont*eel_turn6
8435 cd      write (2,*) 'ekont',ekont
8436 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8437       return
8438       end
8439 crc-------------------------------------------------
8440       SUBROUTINE MATVEC2(A1,V1,V2)
8441       implicit real*8 (a-h,o-z)
8442       include 'DIMENSIONS'
8443       DIMENSION A1(2,2),V1(2),V2(2)
8444 c      DO 1 I=1,2
8445 c        VI=0.0
8446 c        DO 3 K=1,2
8447 c    3     VI=VI+A1(I,K)*V1(K)
8448 c        Vaux(I)=VI
8449 c    1 CONTINUE
8450
8451       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8452       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8453
8454       v2(1)=vaux1
8455       v2(2)=vaux2
8456       END
8457 C---------------------------------------
8458       SUBROUTINE MATMAT2(A1,A2,A3)
8459       implicit real*8 (a-h,o-z)
8460       include 'DIMENSIONS'
8461       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8462 c      DIMENSION AI3(2,2)
8463 c        DO  J=1,2
8464 c          A3IJ=0.0
8465 c          DO K=1,2
8466 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8467 c          enddo
8468 c          A3(I,J)=A3IJ
8469 c       enddo
8470 c      enddo
8471
8472       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8473       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8474       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8475       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8476
8477       A3(1,1)=AI3_11
8478       A3(2,1)=AI3_21
8479       A3(1,2)=AI3_12
8480       A3(2,2)=AI3_22
8481       END
8482
8483 c-------------------------------------------------------------------------
8484       double precision function scalar2(u,v)
8485       implicit none
8486       double precision u(2),v(2)
8487       double precision sc
8488       integer i
8489       scalar2=u(1)*v(1)+u(2)*v(2)
8490       return
8491       end
8492
8493 C-----------------------------------------------------------------------------
8494
8495       subroutine transpose2(a,at)
8496       implicit none
8497       double precision a(2,2),at(2,2)
8498       at(1,1)=a(1,1)
8499       at(1,2)=a(2,1)
8500       at(2,1)=a(1,2)
8501       at(2,2)=a(2,2)
8502       return
8503       end
8504 c--------------------------------------------------------------------------
8505       subroutine transpose(n,a,at)
8506       implicit none
8507       integer n,i,j
8508       double precision a(n,n),at(n,n)
8509       do i=1,n
8510         do j=1,n
8511           at(j,i)=a(i,j)
8512         enddo
8513       enddo
8514       return
8515       end
8516 C---------------------------------------------------------------------------
8517       subroutine prodmat3(a1,a2,kk,transp,prod)
8518       implicit none
8519       integer i,j
8520       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8521       logical transp
8522 crc      double precision auxmat(2,2),prod_(2,2)
8523
8524       if (transp) then
8525 crc        call transpose2(kk(1,1),auxmat(1,1))
8526 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8527 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8528
8529            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8530      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8531            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8532      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8533            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8534      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8535            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8536      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8537
8538       else
8539 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8540 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8541
8542            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8543      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8544            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8545      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8546            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8547      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8548            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8549      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8550
8551       endif
8552 c      call transpose2(a2(1,1),a2t(1,1))
8553
8554 crc      print *,transp
8555 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8556 crc      print *,((prod(i,j),i=1,2),j=1,2)
8557
8558       return
8559       end
8560 C-----------------------------------------------------------------------------
8561       double precision function scalar(u,v)
8562       implicit none
8563       double precision u(3),v(3)
8564       double precision sc
8565       integer i
8566       sc=0.0d0
8567       do i=1,3
8568         sc=sc+u(i)*v(i)
8569       enddo
8570       scalar=sc
8571       return
8572       end
8573 C-----------------------------------------------------------------------
8574       double precision function sscale(r)
8575       double precision r,gamm
8576       include "COMMON.SPLITELE"
8577       if(r.lt.r_cut-rlamb) then
8578         sscale=1.0d0
8579       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8580         gamm=(r-(r_cut-rlamb))/rlamb
8581         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8582       else
8583         sscale=0d0
8584       endif
8585       return
8586       end
8587 C-----------------------------------------------------------------------
8588 C-----------------------------------------------------------------------
8589       double precision function sscagrad(r)
8590       double precision r,gamm
8591       include "COMMON.SPLITELE"
8592       if(r.lt.r_cut-rlamb) then
8593         sscagrad=0.0d0
8594       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8595         gamm=(r-(r_cut-rlamb))/rlamb
8596         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8597       else
8598         sscagrad=0.0d0
8599       endif
8600       return
8601       end
8602 C-----------------------------------------------------------------------
8603 C first for shielding is setting of function of side-chains
8604        subroutine set_shield_fac2
8605       implicit real*8 (a-h,o-z)
8606       include 'DIMENSIONS'
8607       include 'COMMON.CHAIN'
8608       include 'COMMON.DERIV'
8609       include 'COMMON.IOUNITS'
8610       include 'COMMON.SHIELD'
8611       include 'COMMON.INTERACT'
8612 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8613       double precision div77_81/0.974996043d0/,
8614      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8615
8616 C the vector between center of side_chain and peptide group
8617        double precision pep_side(3),long,side_calf(3),
8618      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8619      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8620 C the line belowe needs to be changed for FGPROC>1
8621       do i=1,nres-1
8622       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8623       ishield_list(i)=0
8624 Cif there two consequtive dummy atoms there is no peptide group between them
8625 C the line below has to be changed for FGPROC>1
8626       VolumeTotal=0.0
8627       do k=1,nres
8628        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8629        dist_pep_side=0.0
8630        dist_side_calf=0.0
8631        do j=1,3
8632 C first lets set vector conecting the ithe side-chain with kth side-chain
8633       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8634 C      pep_side(j)=2.0d0
8635 C and vector conecting the side-chain with its proper calfa
8636       side_calf(j)=c(j,k+nres)-c(j,k)
8637 C      side_calf(j)=2.0d0
8638       pept_group(j)=c(j,i)-c(j,i+1)
8639 C lets have their lenght
8640       dist_pep_side=pep_side(j)**2+dist_pep_side
8641       dist_side_calf=dist_side_calf+side_calf(j)**2
8642       dist_pept_group=dist_pept_group+pept_group(j)**2
8643       enddo
8644        dist_pep_side=dsqrt(dist_pep_side)
8645        dist_pept_group=dsqrt(dist_pept_group)
8646        dist_side_calf=dsqrt(dist_side_calf)
8647       do j=1,3
8648         pep_side_norm(j)=pep_side(j)/dist_pep_side
8649         side_calf_norm(j)=dist_side_calf
8650       enddo
8651 C now sscale fraction
8652        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8653 C       print *,buff_shield,"buff"
8654 C now sscale
8655         if (sh_frac_dist.le.0.0) cycle
8656 C If we reach here it means that this side chain reaches the shielding sphere
8657 C Lets add him to the list for gradient
8658         ishield_list(i)=ishield_list(i)+1
8659 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8660 C this list is essential otherwise problem would be O3
8661         shield_list(ishield_list(i),i)=k
8662 C Lets have the sscale value
8663         if (sh_frac_dist.gt.1.0) then
8664          scale_fac_dist=1.0d0
8665          do j=1,3
8666          sh_frac_dist_grad(j)=0.0d0
8667          enddo
8668         else
8669          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8670      &                   *(2.0d0*sh_frac_dist-3.0d0)
8671          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
8672      &                  /dist_pep_side/buff_shield*0.5d0
8673 C remember for the final gradient multiply sh_frac_dist_grad(j)
8674 C for side_chain by factor -2 !
8675          do j=1,3
8676          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8677 C         sh_frac_dist_grad(j)=0.0d0
8678 C         scale_fac_dist=1.0d0
8679 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8680 C     &                    sh_frac_dist_grad(j)
8681          enddo
8682         endif
8683 C this is what is now we have the distance scaling now volume...
8684       short=short_r_sidechain(itype(k))
8685       long=long_r_sidechain(itype(k))
8686       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
8687       sinthet=short/dist_pep_side*costhet
8688 C now costhet_grad
8689 C       costhet=0.6d0
8690 C       sinthet=0.8
8691        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
8692 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
8693 C     &             -short/dist_pep_side**2/costhet)
8694 C       costhet_fac=0.0d0
8695        do j=1,3
8696          costhet_grad(j)=costhet_fac*pep_side(j)
8697        enddo
8698 C remember for the final gradient multiply costhet_grad(j)
8699 C for side_chain by factor -2 !
8700 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8701 C pep_side0pept_group is vector multiplication
8702       pep_side0pept_group=0.0d0
8703       do j=1,3
8704       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8705       enddo
8706       cosalfa=(pep_side0pept_group/
8707      & (dist_pep_side*dist_side_calf))
8708       fac_alfa_sin=1.0d0-cosalfa**2
8709       fac_alfa_sin=dsqrt(fac_alfa_sin)
8710       rkprim=fac_alfa_sin*(long-short)+short
8711 C      rkprim=short
8712
8713 C now costhet_grad
8714        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
8715 C       cosphi=0.6
8716        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
8717        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
8718      &      dist_pep_side**2)
8719 C       sinphi=0.8
8720        do j=1,3
8721          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8722      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8723      &*(long-short)/fac_alfa_sin*cosalfa/
8724      &((dist_pep_side*dist_side_calf))*
8725      &((side_calf(j))-cosalfa*
8726      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8727 C       cosphi_grad_long(j)=0.0d0
8728         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
8729      &*(long-short)/fac_alfa_sin*cosalfa
8730      &/((dist_pep_side*dist_side_calf))*
8731      &(pep_side(j)-
8732      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8733 C       cosphi_grad_loc(j)=0.0d0
8734        enddo
8735 C      print *,sinphi,sinthet
8736       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
8737      &                    /VSolvSphere_div
8738 C     &                    *wshield
8739 C now the gradient...
8740       do j=1,3
8741       grad_shield(j,i)=grad_shield(j,i)
8742 C gradient po skalowaniu
8743      &                +(sh_frac_dist_grad(j)*VofOverlap
8744 C  gradient po costhet
8745      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
8746      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8747      &       sinphi/sinthet*costhet*costhet_grad(j)
8748      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8749      & )*wshield
8750 C grad_shield_side is Cbeta sidechain gradient
8751       grad_shield_side(j,ishield_list(i),i)=
8752      &        (sh_frac_dist_grad(j)*-2.0d0
8753      &        *VofOverlap
8754      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8755      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
8756      &       sinphi/sinthet*costhet*costhet_grad(j)
8757      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
8758      &       )*wshield
8759
8760        grad_shield_loc(j,ishield_list(i),i)=
8761      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
8762      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
8763      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
8764      &        ))
8765      &        *wshield
8766       enddo
8767       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8768       enddo
8769       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
8770 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8771       enddo
8772       return
8773       end
8774 C first for shielding is setting of function of side-chains
8775        subroutine set_shield_fac
8776       implicit real*8 (a-h,o-z)
8777       include 'DIMENSIONS'
8778       include 'COMMON.CHAIN'
8779       include 'COMMON.DERIV'
8780       include 'COMMON.IOUNITS'
8781       include 'COMMON.SHIELD'
8782       include 'COMMON.INTERACT'
8783 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8784       double precision div77_81/0.974996043d0/,
8785      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8786
8787 C the vector between center of side_chain and peptide group
8788        double precision pep_side(3),long,side_calf(3),
8789      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8790      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8791 C the line belowe needs to be changed for FGPROC>1
8792       do i=1,nres-1
8793       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8794       ishield_list(i)=0
8795 Cif there two consequtive dummy atoms there is no peptide group between them
8796 C the line below has to be changed for FGPROC>1
8797       VolumeTotal=0.0
8798       do k=1,nres
8799        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8800        dist_pep_side=0.0
8801        dist_side_calf=0.0
8802        do j=1,3
8803 C first lets set vector conecting the ithe side-chain with kth side-chain
8804       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8805 C      pep_side(j)=2.0d0
8806 C and vector conecting the side-chain with its proper calfa
8807       side_calf(j)=c(j,k+nres)-c(j,k)
8808 C      side_calf(j)=2.0d0
8809       pept_group(j)=c(j,i)-c(j,i+1)
8810 C lets have their lenght
8811       dist_pep_side=pep_side(j)**2+dist_pep_side
8812       dist_side_calf=dist_side_calf+side_calf(j)**2
8813       dist_pept_group=dist_pept_group+pept_group(j)**2
8814       enddo
8815        dist_pep_side=dsqrt(dist_pep_side)
8816        dist_pept_group=dsqrt(dist_pept_group)
8817        dist_side_calf=dsqrt(dist_side_calf)
8818       do j=1,3
8819         pep_side_norm(j)=pep_side(j)/dist_pep_side
8820         side_calf_norm(j)=dist_side_calf
8821       enddo
8822 C now sscale fraction
8823        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8824 C       print *,buff_shield,"buff"
8825 C now sscale
8826         if (sh_frac_dist.le.0.0) cycle
8827 C If we reach here it means that this side chain reaches the shielding sphere
8828 C Lets add him to the list for gradient
8829         ishield_list(i)=ishield_list(i)+1
8830 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8831 C this list is essential otherwise problem would be O3
8832         shield_list(ishield_list(i),i)=k
8833 C Lets have the sscale value
8834         if (sh_frac_dist.gt.1.0) then
8835          scale_fac_dist=1.0d0
8836          do j=1,3
8837          sh_frac_dist_grad(j)=0.0d0
8838          enddo
8839         else
8840          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8841      &                   *(2.0*sh_frac_dist-3.0d0)
8842          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8843      &                  /dist_pep_side/buff_shield*0.5
8844 C remember for the final gradient multiply sh_frac_dist_grad(j)
8845 C for side_chain by factor -2 !
8846          do j=1,3
8847          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8848 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8849 C     &                    sh_frac_dist_grad(j)
8850          enddo
8851         endif
8852 C        if ((i.eq.3).and.(k.eq.2)) then
8853 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8854 C     & ,"TU"
8855 C        endif
8856
8857 C this is what is now we have the distance scaling now volume...
8858       short=short_r_sidechain(itype(k))
8859       long=long_r_sidechain(itype(k))
8860       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8861 C now costhet_grad
8862 C       costhet=0.0d0
8863        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8864 C       costhet_fac=0.0d0
8865        do j=1,3
8866          costhet_grad(j)=costhet_fac*pep_side(j)
8867        enddo
8868 C remember for the final gradient multiply costhet_grad(j)
8869 C for side_chain by factor -2 !
8870 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8871 C pep_side0pept_group is vector multiplication
8872       pep_side0pept_group=0.0
8873       do j=1,3
8874       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8875       enddo
8876       cosalfa=(pep_side0pept_group/
8877      & (dist_pep_side*dist_side_calf))
8878       fac_alfa_sin=1.0-cosalfa**2
8879       fac_alfa_sin=dsqrt(fac_alfa_sin)
8880       rkprim=fac_alfa_sin*(long-short)+short
8881 C now costhet_grad
8882        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8883        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8884
8885        do j=1,3
8886          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8887      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8888      &*(long-short)/fac_alfa_sin*cosalfa/
8889      &((dist_pep_side*dist_side_calf))*
8890      &((side_calf(j))-cosalfa*
8891      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8892
8893         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8894      &*(long-short)/fac_alfa_sin*cosalfa
8895      &/((dist_pep_side*dist_side_calf))*
8896      &(pep_side(j)-
8897      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8898        enddo
8899
8900       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8901      &                    /VSolvSphere_div
8902      &                    *wshield
8903 C now the gradient...
8904 C grad_shield is gradient of Calfa for peptide groups
8905 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8906 C     &               costhet,cosphi
8907 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8908 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8909       do j=1,3
8910       grad_shield(j,i)=grad_shield(j,i)
8911 C gradient po skalowaniu
8912      &                +(sh_frac_dist_grad(j)
8913 C  gradient po costhet
8914      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8915      &-scale_fac_dist*(cosphi_grad_long(j))
8916      &/(1.0-cosphi) )*div77_81
8917      &*VofOverlap
8918 C grad_shield_side is Cbeta sidechain gradient
8919       grad_shield_side(j,ishield_list(i),i)=
8920      &        (sh_frac_dist_grad(j)*-2.0d0
8921      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
8922      &       +scale_fac_dist*(cosphi_grad_long(j))
8923      &        *2.0d0/(1.0-cosphi))
8924      &        *div77_81*VofOverlap
8925
8926        grad_shield_loc(j,ishield_list(i),i)=
8927      &   scale_fac_dist*cosphi_grad_loc(j)
8928      &        *2.0d0/(1.0-cosphi)
8929      &        *div77_81*VofOverlap
8930       enddo
8931       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
8932       enddo
8933       fac_shield(i)=VolumeTotal*div77_81+div4_81
8934 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
8935       enddo
8936       return
8937       end
8938 C--------------------------------------------------------------------------
8939 C-----------------------------------------------------------------------
8940       double precision function sscalelip(r)
8941       double precision r,gamm
8942       include "COMMON.SPLITELE"
8943 C      if(r.lt.r_cut-rlamb) then
8944 C        sscale=1.0d0
8945 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8946 C        gamm=(r-(r_cut-rlamb))/rlamb
8947         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8948 C      else
8949 C        sscale=0d0
8950 C      endif
8951       return
8952       end
8953 C-----------------------------------------------------------------------
8954       double precision function sscagradlip(r)
8955       double precision r,gamm
8956       include "COMMON.SPLITELE"
8957 C     if(r.lt.r_cut-rlamb) then
8958 C        sscagrad=0.0d0
8959 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8960 C        gamm=(r-(r_cut-rlamb))/rlamb
8961         sscagradlip=r*(6*r-6.0d0)
8962 C      else
8963 C        sscagrad=0.0d0
8964 C      endif
8965       return
8966       end
8967
8968 C-----------------------------------------------------------------------
8969 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8970       subroutine Eliptransfer(eliptran)
8971       implicit real*8 (a-h,o-z)
8972       include 'DIMENSIONS'
8973       include 'COMMON.GEO'
8974       include 'COMMON.VAR'
8975       include 'COMMON.LOCAL'
8976       include 'COMMON.CHAIN'
8977       include 'COMMON.DERIV'
8978       include 'COMMON.INTERACT'
8979       include 'COMMON.IOUNITS'
8980       include 'COMMON.CALC'
8981       include 'COMMON.CONTROL'
8982       include 'COMMON.SPLITELE'
8983       include 'COMMON.SBRIDGE'
8984 C this is done by Adasko
8985 C      print *,"wchodze"
8986 C structure of box:
8987 C      water
8988 C--bordliptop-- buffore starts
8989 C--bufliptop--- here true lipid starts
8990 C      lipid
8991 C--buflipbot--- lipid ends buffore starts
8992 C--bordlipbot--buffore ends
8993       eliptran=0.0
8994       write(iout,*) "I am in?"
8995       do i=1,nres
8996 C       do i=1,1
8997         if (itype(i).eq.ntyp1) cycle
8998
8999         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9000         if (positi.le.0) positi=positi+boxzsize
9001 C        print *,i
9002 C first for peptide groups
9003 c for each residue check if it is in lipid or lipid water border area
9004        if ((positi.gt.bordlipbot)
9005      &.and.(positi.lt.bordliptop)) then
9006 C the energy transfer exist
9007         if (positi.lt.buflipbot) then
9008 C what fraction I am in
9009          fracinbuf=1.0d0-
9010      &        ((positi-bordlipbot)/lipbufthick)
9011 C lipbufthick is thickenes of lipid buffore
9012          sslip=sscalelip(fracinbuf)
9013          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9014          eliptran=eliptran+sslip*pepliptran
9015          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9016          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9017 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9018         elseif (positi.gt.bufliptop) then
9019          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9020          sslip=sscalelip(fracinbuf)
9021          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9022          eliptran=eliptran+sslip*pepliptran
9023          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9024          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9025 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9026 C          print *, "doing sscalefor top part"
9027 C         print *,i,sslip,fracinbuf,ssgradlip
9028         else
9029          eliptran=eliptran+pepliptran
9030 C         print *,"I am in true lipid"
9031         endif
9032 C       else
9033 C       eliptran=elpitran+0.0 ! I am in water
9034        endif
9035        enddo
9036 C       print *, "nic nie bylo w lipidzie?"
9037 C now multiply all by the peptide group transfer factor
9038 C       eliptran=eliptran*pepliptran
9039 C now the same for side chains
9040 CV       do i=1,1
9041        do i=1,nres
9042         if (itype(i).eq.ntyp1) cycle
9043         positi=(mod(c(3,i+nres),boxzsize))
9044         if (positi.le.0) positi=positi+boxzsize
9045 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9046 c for each residue check if it is in lipid or lipid water border area
9047 C       respos=mod(c(3,i+nres),boxzsize)
9048 C       print *,positi,bordlipbot,buflipbot
9049        if ((positi.gt.bordlipbot)
9050      & .and.(positi.lt.bordliptop)) then
9051 C the energy transfer exist
9052         if (positi.lt.buflipbot) then
9053          fracinbuf=1.0d0-
9054      &     ((positi-bordlipbot)/lipbufthick)
9055 C lipbufthick is thickenes of lipid buffore
9056          sslip=sscalelip(fracinbuf)
9057          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9058          eliptran=eliptran+sslip*liptranene(itype(i))
9059          gliptranx(3,i)=gliptranx(3,i)
9060      &+ssgradlip*liptranene(itype(i))
9061          gliptranc(3,i-1)= gliptranc(3,i-1)
9062      &+ssgradlip*liptranene(itype(i))
9063 C         print *,"doing sccale for lower part"
9064         elseif (positi.gt.bufliptop) then
9065          fracinbuf=1.0d0-
9066      &((bordliptop-positi)/lipbufthick)
9067          sslip=sscalelip(fracinbuf)
9068          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9069          eliptran=eliptran+sslip*liptranene(itype(i))
9070          gliptranx(3,i)=gliptranx(3,i)
9071      &+ssgradlip*liptranene(itype(i))
9072          gliptranc(3,i-1)= gliptranc(3,i-1)
9073      &+ssgradlip*liptranene(itype(i))
9074 C          print *, "doing sscalefor top part",sslip,fracinbuf
9075         else
9076          eliptran=eliptran+liptranene(itype(i))
9077 C         print *,"I am in true lipid"
9078         endif
9079         endif ! if in lipid or buffor
9080 C       else
9081 C       eliptran=elpitran+0.0 ! I am in water
9082        enddo
9083        return
9084        end
9085 C-------------------------------------------------------------------------------------
9086 C-----------------------------------------------------------------------
9087 C-----------------------------------------------------------
9088 C This subroutine is to mimic the histone like structure but as well can be
9089 C utilizet to nanostructures (infinit) small modification has to be used to
9090 C make it finite (z gradient at the ends has to be changes as well as the x,y
9091 C gradient has to be modified at the ends
9092 C The energy function is Kihara potential
9093 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9094 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9095 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9096 C simple Kihara potential
9097       subroutine calctube(Etube)
9098        implicit real*8 (a-h,o-z)
9099       include 'DIMENSIONS'
9100       include 'COMMON.GEO'
9101       include 'COMMON.VAR'
9102       include 'COMMON.LOCAL'
9103       include 'COMMON.CHAIN'
9104       include 'COMMON.DERIV'
9105       include 'COMMON.INTERACT'
9106       include 'COMMON.IOUNITS'
9107       include 'COMMON.CALC'
9108       include 'COMMON.CONTROL'
9109       include 'COMMON.SPLITELE'
9110       include 'COMMON.SBRIDGE'
9111       double precision tub_r,vectube(3),enetube(maxres*2)
9112       Etube=0.0d0
9113       do i=itube_start,itube_end
9114         enetube(i)=0.0d0
9115         enetube(i+nres)=0.0d0
9116       enddo
9117 C first we calculate the distance from tube center
9118 C first sugare-phosphate group for NARES this would be peptide group
9119 C for UNRES
9120        do i=itube_start,itube_end
9121 C lets ommit dummy atoms for now
9122        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9123 C now calculate distance from center of tube and direction vectors
9124       xmin=boxxsize
9125       ymin=boxysize
9126         do j=-1,1
9127          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9128          vectube(1)=vectube(1)+boxxsize*j
9129          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9130          vectube(2)=vectube(2)+boxysize*j
9131
9132          xminact=abs(vectube(1)-tubecenter(1))
9133          yminact=abs(vectube(2)-tubecenter(2))
9134            if (xmin.gt.xminact) then
9135             xmin=xminact
9136             xtemp=vectube(1)
9137            endif
9138            if (ymin.gt.yminact) then
9139              ymin=yminact
9140              ytemp=vectube(2)
9141             endif
9142          enddo
9143       vectube(1)=xtemp
9144       vectube(2)=ytemp
9145       vectube(1)=vectube(1)-tubecenter(1)
9146       vectube(2)=vectube(2)-tubecenter(2)
9147
9148 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9149 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9150
9151 C as the tube is infinity we do not calculate the Z-vector use of Z
9152 C as chosen axis
9153       vectube(3)=0.0d0
9154 C now calculte the distance
9155        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9156 C now normalize vector
9157       vectube(1)=vectube(1)/tub_r
9158       vectube(2)=vectube(2)/tub_r
9159 C calculte rdiffrence between r and r0
9160       rdiff=tub_r-tubeR0
9161 C and its 6 power
9162       rdiff6=rdiff**6.0d0
9163 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9164        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
9165 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9166 C       print *,rdiff,rdiff6,pep_aa_tube
9167 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9168 C now we calculate gradient
9169        fac=(-12.0d0*pep_aa_tube/rdiff6-
9170      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
9171 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9172 C     &rdiff,fac
9173
9174 C now direction of gg_tube vector
9175         do j=1,3
9176         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9177         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9178         enddo
9179         enddo
9180 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
9181 C        print *,gg_tube(1,0),"TU"
9182
9183
9184        do i=itube_start,itube_end
9185 C Lets not jump over memory as we use many times iti
9186          iti=itype(i)
9187 C lets ommit dummy atoms for now
9188          if ((iti.eq.ntyp1)
9189 C in UNRES uncomment the line below as GLY has no side-chain...
9190 C      .or.(iti.eq.10)
9191      &   ) cycle
9192       xmin=boxxsize
9193       ymin=boxysize
9194         do j=-1,1
9195          vectube(1)=mod((c(1,i+nres)),boxxsize)
9196          vectube(1)=vectube(1)+boxxsize*j
9197          vectube(2)=mod((c(2,i+nres)),boxysize)
9198          vectube(2)=vectube(2)+boxysize*j
9199
9200          xminact=abs(vectube(1)-tubecenter(1))
9201          yminact=abs(vectube(2)-tubecenter(2))
9202            if (xmin.gt.xminact) then
9203             xmin=xminact
9204             xtemp=vectube(1)
9205            endif
9206            if (ymin.gt.yminact) then
9207              ymin=yminact
9208              ytemp=vectube(2)
9209             endif
9210          enddo
9211       vectube(1)=xtemp
9212       vectube(2)=ytemp
9213 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
9214 C     &     tubecenter(2)
9215       vectube(1)=vectube(1)-tubecenter(1)
9216       vectube(2)=vectube(2)-tubecenter(2)
9217
9218 C as the tube is infinity we do not calculate the Z-vector use of Z
9219 C as chosen axis
9220       vectube(3)=0.0d0
9221 C now calculte the distance
9222        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9223 C now normalize vector
9224       vectube(1)=vectube(1)/tub_r
9225       vectube(2)=vectube(2)/tub_r
9226
9227 C calculte rdiffrence between r and r0
9228       rdiff=tub_r-tubeR0
9229 C and its 6 power
9230       rdiff6=rdiff**6.0d0
9231 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9232        sc_aa_tube=sc_aa_tube_par(iti)
9233        sc_bb_tube=sc_bb_tube_par(iti)
9234        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
9235 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9236 C now we calculate gradient
9237        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9238      &       6.0d0*sc_bb_tube/rdiff6/rdiff
9239 C now direction of gg_tube vector
9240          do j=1,3
9241           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9242           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9243          enddo
9244         enddo
9245         do i=itube_start,itube_end
9246           Etube=Etube+enetube(i)+enetube(i+nres)
9247         enddo
9248 C        print *,"ETUBE", etube
9249         return
9250         end
9251 C TO DO 1) add to total energy
9252 C       2) add to gradient summation
9253 C       3) add reading parameters (AND of course oppening of PARAM file)
9254 C       4) add reading the center of tube
9255 C       5) add COMMONs
9256 C       6) add to zerograd
9257
9258 C-----------------------------------------------------------------------
9259 C-----------------------------------------------------------
9260 C This subroutine is to mimic the histone like structure but as well can be
9261 C utilizet to nanostructures (infinit) small modification has to be used to
9262 C make it finite (z gradient at the ends has to be changes as well as the x,y
9263 C gradient has to be modified at the ends
9264 C The energy function is Kihara potential
9265 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9266 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9267 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9268 C simple Kihara potential
9269       subroutine calctube2(Etube)
9270        implicit real*8 (a-h,o-z)
9271       include 'DIMENSIONS'
9272       include 'COMMON.GEO'
9273       include 'COMMON.VAR'
9274       include 'COMMON.LOCAL'
9275       include 'COMMON.CHAIN'
9276       include 'COMMON.DERIV'
9277       include 'COMMON.INTERACT'
9278       include 'COMMON.IOUNITS'
9279       include 'COMMON.CALC'
9280       include 'COMMON.CONTROL'
9281       include 'COMMON.SPLITELE'
9282       include 'COMMON.SBRIDGE'
9283       double precision tub_r,vectube(3),enetube(maxres*2)
9284       Etube=0.0d0
9285       do i=itube_start,itube_end
9286         enetube(i)=0.0d0
9287         enetube(i+nres)=0.0d0
9288       enddo
9289 C first we calculate the distance from tube center
9290 C first sugare-phosphate group for NARES this would be peptide group
9291 C for UNRES
9292        do i=itube_start,itube_end
9293 C lets ommit dummy atoms for now
9294
9295        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9296 C now calculate distance from center of tube and direction vectors
9297 C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9298 C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
9299 C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9300 C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
9301       xmin=boxxsize
9302       ymin=boxysize
9303         do j=-1,1
9304          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9305          vectube(1)=vectube(1)+boxxsize*j
9306          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9307          vectube(2)=vectube(2)+boxysize*j
9308
9309          xminact=abs(vectube(1)-tubecenter(1))
9310          yminact=abs(vectube(2)-tubecenter(2))
9311            if (xmin.gt.xminact) then
9312             xmin=xminact
9313             xtemp=vectube(1)
9314            endif
9315            if (ymin.gt.yminact) then
9316              ymin=yminact
9317              ytemp=vectube(2)
9318             endif
9319          enddo
9320       vectube(1)=xtemp
9321       vectube(2)=ytemp
9322       vectube(1)=vectube(1)-tubecenter(1)
9323       vectube(2)=vectube(2)-tubecenter(2)
9324
9325 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9326 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9327
9328 C as the tube is infinity we do not calculate the Z-vector use of Z
9329 C as chosen axis
9330       vectube(3)=0.0d0
9331 C now calculte the distance
9332        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9333 C now normalize vector
9334       vectube(1)=vectube(1)/tub_r
9335       vectube(2)=vectube(2)/tub_r
9336 C calculte rdiffrence between r and r0
9337       rdiff=tub_r-tubeR0
9338 C and its 6 power
9339       rdiff6=rdiff**6.0d0
9340 C THIS FRAGMENT MAKES TUBE FINITE
9341         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
9342         if (positi.le.0) positi=positi+boxzsize
9343 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9344 c for each residue check if it is in lipid or lipid water border area
9345 C       respos=mod(c(3,i+nres),boxzsize)
9346        print *,positi,bordtubebot,buftubebot,bordtubetop
9347        if ((positi.gt.bordtubebot)
9348      & .and.(positi.lt.bordtubetop)) then
9349 C the energy transfer exist
9350         if (positi.lt.buftubebot) then
9351          fracinbuf=1.0d0-
9352      &     ((positi-bordtubebot)/tubebufthick)
9353 C lipbufthick is thickenes of lipid buffore
9354          sstube=sscalelip(fracinbuf)
9355          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
9356          print *,ssgradtube, sstube,tubetranene(itype(i))
9357          enetube(i)=enetube(i)+sstube*tubetranenepep
9358 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9359 C     &+ssgradtube*tubetranene(itype(i))
9360 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9361 C     &+ssgradtube*tubetranene(itype(i))
9362 C         print *,"doing sccale for lower part"
9363         elseif (positi.gt.buftubetop) then
9364          fracinbuf=1.0d0-
9365      &((bordtubetop-positi)/tubebufthick)
9366          sstube=sscalelip(fracinbuf)
9367          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
9368          enetube(i)=enetube(i)+sstube*tubetranenepep
9369 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9370 C     &+ssgradtube*tubetranene(itype(i))
9371 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9372 C     &+ssgradtube*tubetranene(itype(i))
9373 C          print *, "doing sscalefor top part",sslip,fracinbuf
9374         else
9375          sstube=1.0d0
9376          ssgradtube=0.0d0
9377          enetube(i)=enetube(i)+sstube*tubetranenepep
9378 C         print *,"I am in true lipid"
9379         endif
9380         else
9381 C          sstube=0.0d0
9382 C          ssgradtube=0.0d0
9383         cycle
9384         endif ! if in lipid or buffor
9385
9386 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9387        enetube(i)=enetube(i)+sstube*
9388      &(pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
9389 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9390 C       print *,rdiff,rdiff6,pep_aa_tube
9391 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9392 C now we calculate gradient
9393        fac=(-12.0d0*pep_aa_tube/rdiff6-
9394      &       6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
9395 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9396 C     &rdiff,fac
9397
9398 C now direction of gg_tube vector
9399         do j=1,3
9400         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9401         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9402         enddo
9403          gg_tube(3,i)=gg_tube(3,i)
9404      &+ssgradtube*enetube(i)/sstube/2.0d0
9405          gg_tube(3,i-1)= gg_tube(3,i-1)
9406      &+ssgradtube*enetube(i)/sstube/2.0d0
9407
9408         enddo
9409 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
9410 C        print *,gg_tube(1,0),"TU"
9411         do i=itube_start,itube_end
9412 C Lets not jump over memory as we use many times iti
9413          iti=itype(i)
9414 C lets ommit dummy atoms for now
9415          if ((iti.eq.ntyp1)
9416 C in UNRES uncomment the line below as GLY has no side-chain...
9417      &      .or.(iti.eq.10)
9418      &   ) cycle
9419           vectube(1)=c(1,i+nres)
9420           vectube(1)=mod(vectube(1),boxxsize)
9421           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
9422           vectube(2)=c(2,i+nres)
9423           vectube(2)=mod(vectube(2),boxysize)
9424           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
9425
9426       vectube(1)=vectube(1)-tubecenter(1)
9427       vectube(2)=vectube(2)-tubecenter(2)
9428 C THIS FRAGMENT MAKES TUBE FINITE
9429         positi=(mod(c(3,i+nres),boxzsize))
9430         if (positi.le.0) positi=positi+boxzsize
9431 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9432 c for each residue check if it is in lipid or lipid water border area
9433 C       respos=mod(c(3,i+nres),boxzsize)
9434        print *,positi,bordtubebot,buftubebot,bordtubetop
9435        if ((positi.gt.bordtubebot)
9436      & .and.(positi.lt.bordtubetop)) then
9437 C the energy transfer exist
9438         if (positi.lt.buftubebot) then
9439          fracinbuf=1.0d0-
9440      &     ((positi-bordtubebot)/tubebufthick)
9441 C lipbufthick is thickenes of lipid buffore
9442          sstube=sscalelip(fracinbuf)
9443          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
9444          print *,ssgradtube, sstube,tubetranene(itype(i))
9445          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9446 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9447 C     &+ssgradtube*tubetranene(itype(i))
9448 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9449 C     &+ssgradtube*tubetranene(itype(i))
9450 C         print *,"doing sccale for lower part"
9451         elseif (positi.gt.buftubetop) then
9452          fracinbuf=1.0d0-
9453      &((bordtubetop-positi)/tubebufthick)
9454          sstube=sscalelip(fracinbuf)
9455          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
9456          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9457 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9458 C     &+ssgradtube*tubetranene(itype(i))
9459 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9460 C     &+ssgradtube*tubetranene(itype(i))
9461 C          print *, "doing sscalefor top part",sslip,fracinbuf
9462         else
9463          sstube=1.0d0
9464          ssgradtube=0.0d0
9465          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9466 C         print *,"I am in true lipid"
9467         endif
9468         else
9469 C          sstube=0.0d0
9470 C          ssgradtube=0.0d0
9471         cycle
9472         endif ! if in lipid or buffor
9473 CEND OF FINITE FRAGMENT
9474 C as the tube is infinity we do not calculate the Z-vector use of Z
9475 C as chosen axis
9476       vectube(3)=0.0d0
9477 C now calculte the distance
9478        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9479 C now normalize vector
9480       vectube(1)=vectube(1)/tub_r
9481       vectube(2)=vectube(2)/tub_r
9482 C calculte rdiffrence between r and r0
9483       rdiff=tub_r-tubeR0
9484 C and its 6 power
9485       rdiff6=rdiff**6.0d0
9486 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9487        sc_aa_tube=sc_aa_tube_par(iti)
9488        sc_bb_tube=sc_bb_tube_par(iti)
9489        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
9490      &                 *sstube+enetube(i+nres)
9491 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9492 C now we calculate gradient
9493        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9494      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
9495 C now direction of gg_tube vector
9496          do j=1,3
9497           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9498           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9499          enddo
9500          gg_tube_SC(3,i)=gg_tube_SC(3,i)
9501      &+ssgradtube*enetube(i+nres)/sstube
9502          gg_tube(3,i-1)= gg_tube(3,i-1)
9503      &+ssgradtube*enetube(i+nres)/sstube
9504
9505         enddo
9506         do i=itube_start,itube_end
9507           Etube=Etube+enetube(i)+enetube(i+nres)
9508         enddo
9509 C        print *,"ETUBE", etube
9510         return
9511         end
9512 C TO DO 1) add to total energy
9513 C       2) add to gradient summation
9514 C       3) add reading parameters (AND of course oppening of PARAM file)
9515 C       4) add reading the center of tube
9516 C       5) add COMMONs
9517 C       6) add to zerograd
9518
9519
9520 C#-------------------------------------------------------------------------------
9521 C This subroutine is to mimic the histone like structure but as well can be
9522 C utilizet to nanostructures (infinit) small modification has to be used to
9523 C make it finite (z gradient at the ends has to be changes as well as the x,y
9524 C gradient has to be modified at the ends
9525 C The energy function is Kihara potential
9526 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9527 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9528 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9529 C simple Kihara potential
9530       subroutine calcnano(Etube)
9531        implicit real*8 (a-h,o-z)
9532       include 'DIMENSIONS'
9533       include 'COMMON.GEO'
9534       include 'COMMON.VAR'
9535       include 'COMMON.LOCAL'
9536       include 'COMMON.CHAIN'
9537       include 'COMMON.DERIV'
9538       include 'COMMON.INTERACT'
9539       include 'COMMON.IOUNITS'
9540       include 'COMMON.CALC'
9541       include 'COMMON.CONTROL'
9542       include 'COMMON.SPLITELE'
9543       include 'COMMON.SBRIDGE'
9544       double precision tub_r,vectube(3),enetube(maxres*2),
9545      & enecavtube(maxres*2)
9546       Etube=0.0d0
9547       do i=itube_start,itube_end
9548         enetube(i)=0.0d0
9549         enetube(i+nres)=0.0d0
9550       enddo
9551 C first we calculate the distance from tube center
9552 C first sugare-phosphate group for NARES this would be peptide group
9553 C for UNRES
9554        do i=itube_start,itube_end
9555 C lets ommit dummy atoms for now
9556        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9557 C now calculate distance from center of tube and direction vectors
9558       xmin=boxxsize
9559       ymin=boxysize
9560       zmin=boxzsize
9561
9562         do j=-1,1
9563          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9564          vectube(1)=vectube(1)+boxxsize*j
9565          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9566          vectube(2)=vectube(2)+boxysize*j
9567          vectube(3)=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
9568          vectube(3)=vectube(3)+boxzsize*j
9569
9570
9571          xminact=abs(vectube(1)-tubecenter(1))
9572          yminact=abs(vectube(2)-tubecenter(2))
9573          zminact=abs(vectube(3)-tubecenter(3))
9574
9575            if (xmin.gt.xminact) then
9576             xmin=xminact
9577             xtemp=vectube(1)
9578            endif
9579            if (ymin.gt.yminact) then
9580              ymin=yminact
9581              ytemp=vectube(2)
9582             endif
9583            if (zmin.gt.zminact) then
9584              zmin=zminact
9585              ztemp=vectube(3)
9586             endif
9587          enddo
9588       vectube(1)=xtemp
9589       vectube(2)=ytemp
9590       vectube(3)=ztemp
9591
9592       vectube(1)=vectube(1)-tubecenter(1)
9593       vectube(2)=vectube(2)-tubecenter(2)
9594       vectube(3)=vectube(3)-tubecenter(3)
9595
9596 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9597 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9598 C as the tube is infinity we do not calculate the Z-vector use of Z
9599 C as chosen axis
9600 C      vectube(3)=0.0d0
9601 C now calculte the distance
9602        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9603 C now normalize vector
9604       vectube(1)=vectube(1)/tub_r
9605       vectube(2)=vectube(2)/tub_r
9606       vectube(3)=vectube(3)/tub_r
9607 C calculte rdiffrence between r and r0
9608       rdiff=tub_r-tubeR0
9609 C and its 6 power
9610       rdiff6=rdiff**6.0d0
9611 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9612        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
9613 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9614 C       print *,rdiff,rdiff6,pep_aa_tube
9615 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9616 C now we calculate gradient
9617        fac=(-12.0d0*pep_aa_tube/rdiff6-
9618      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
9619 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9620 C     &rdiff,fac
9621          if (acavtubpep.eq.0.0d0) then
9622 C go to 667
9623          enecavtube(i)=0.0
9624          faccav=0.0
9625          else
9626          denominator=(1.0+dcavtubpep*rdiff6*rdiff6)
9627          enecavtube(i)=
9628      &   (bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)+ccavtubpep)
9629      &   /denominator
9630          enecavtube(i)=0.0
9631          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/sqrt(rdiff))
9632      &   *denominator-(bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)
9633      &   +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)
9634      &   /denominator**2.0d0
9635 C         faccav=0.0
9636 C         fac=fac+faccav
9637 C 667     continue
9638          endif
9639 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtubpep,denominator,
9640 C     &   enecavtube(i),faccav
9641 C         print *,"licz=",
9642 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9643 CX         print *,"finene=",enetube(i+nres)+enecavtube(i)
9644
9645 C now direction of gg_tube vector
9646         do j=1,3
9647         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9648         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9649         enddo
9650         enddo
9651
9652        do i=itube_start,itube_end
9653         enecavtube(i)=0.0
9654 C Lets not jump over memory as we use many times iti
9655          iti=itype(i)
9656 C lets ommit dummy atoms for now
9657          if ((iti.eq.ntyp1)
9658 C in UNRES uncomment the line below as GLY has no side-chain...
9659 C      .or.(iti.eq.10)
9660      &   ) cycle
9661       xmin=boxxsize
9662       ymin=boxysize
9663       zmin=boxzsize
9664         do j=-1,1
9665          vectube(1)=mod((c(1,i+nres)),boxxsize)
9666          vectube(1)=vectube(1)+boxxsize*j
9667          vectube(2)=mod((c(2,i+nres)),boxysize)
9668          vectube(2)=vectube(2)+boxysize*j
9669          vectube(3)=mod((c(3,i+nres)),boxzsize)
9670          vectube(3)=vectube(3)+boxzsize*j
9671
9672
9673          xminact=abs(vectube(1)-tubecenter(1))
9674          yminact=abs(vectube(2)-tubecenter(2))
9675          zminact=abs(vectube(3)-tubecenter(3))
9676
9677            if (xmin.gt.xminact) then
9678             xmin=xminact
9679             xtemp=vectube(1)
9680            endif
9681            if (ymin.gt.yminact) then
9682              ymin=yminact
9683              ytemp=vectube(2)
9684             endif
9685            if (zmin.gt.zminact) then
9686              zmin=zminact
9687              ztemp=vectube(3)
9688             endif
9689          enddo
9690       vectube(1)=xtemp
9691       vectube(2)=ytemp
9692       vectube(3)=ztemp
9693
9694 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
9695 C     &     tubecenter(2)
9696       vectube(1)=vectube(1)-tubecenter(1)
9697       vectube(2)=vectube(2)-tubecenter(2)
9698       vectube(3)=vectube(3)-tubecenter(3)
9699 C now calculte the distance
9700        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9701 C now normalize vector
9702       vectube(1)=vectube(1)/tub_r
9703       vectube(2)=vectube(2)/tub_r
9704       vectube(3)=vectube(3)/tub_r
9705
9706 C calculte rdiffrence between r and r0
9707       rdiff=tub_r-tubeR0
9708 C and its 6 power
9709       rdiff6=rdiff**6.0d0
9710 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9711        sc_aa_tube=sc_aa_tube_par(iti)
9712        sc_bb_tube=sc_bb_tube_par(iti)
9713        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
9714 C       enetube(i+nres)=0.0d0
9715 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9716 C now we calculate gradient
9717        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9718      &       6.0d0*sc_bb_tube/rdiff6/rdiff
9719 C       fac=0.0
9720 C now direction of gg_tube vector
9721 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
9722          if (acavtub(iti).eq.0.0d0) then
9723 C go to 667
9724          enecavtube(i+nres)=0.0
9725          faccav=0.0
9726          else
9727          denominator=(1.0+dcavtub(iti)*rdiff6*rdiff6)
9728          enecavtube(i+nres)=
9729      &   (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9730      &   /denominator
9731 C         enecavtube(i)=0.0
9732          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/sqrt(rdiff))
9733      &   *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)
9734      &   +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)
9735      &   /denominator**2.0d0
9736 C         faccav=0.0
9737          fac=fac+faccav
9738 C 667     continue
9739          endif
9740 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
9741 C     &   enecavtube(i),faccav
9742 C         print *,"licz=",
9743 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9744 C         print *,"finene=",enetube(i+nres)+enecavtube(i)
9745          do j=1,3
9746           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9747           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9748          enddo
9749         enddo
9750 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
9751 C        do i=itube_start,itube_end
9752 C        enecav(i)=0.0
9753 C        iti=itype(i)
9754 C        if (acavtub(iti).eq.0.0) cycle
9755
9756
9757
9758         do i=itube_start,itube_end
9759           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i)
9760      & +enecavtube(i+nres)
9761         enddo
9762 C        print *,"ETUBE", etube
9763         return
9764         end
9765 C TO DO 1) add to total energy
9766 C       2) add to gradient summation
9767 C       3) add reading parameters (AND of course oppening of PARAM file)
9768 C       4) add reading the center of tube
9769 C       5) add COMMONs
9770 C       6) add to zerograd
9771