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