source/wham/src-M/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.SHIELD'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C      write(iout,*) 'po elektostatyce'
  50 C
  51 C Calculate electrostatic (H-bonding) energy of the main chain.
  52 C
  53   106 continue
  54       if (shield_mode.eq.1) then
  55        call set_shield_fac
  56       else if  (shield_mode.eq.2) then
  57        call set_shield_fac2
  58       endif
  59       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  60 C            write(iout,*) 'po eelec'
  61
  62 C Calculate excluded-volume interaction energy between peptide groups
  63 C and side chains.
  64 C
  65       call escp(evdw2,evdw2_14)
  66 c
  67 c Calculate the bond-stretching energy
  68 c
  69
  70       call ebond(estr)
  71 C       write (iout,*) "estr",estr
  72 C
  73 C Calculate the disulfide-bridge and other energy and the contributions
  74 C from other distance constraints.
  75 cd    print *,'Calling EHPB'
  76       call edis(ehpb)
  77 cd    print *,'EHPB exitted succesfully.'
  78 C
  79 C Calculate the virtual-bond-angle energy.
  80 C
  81 C      print *,'Bend energy finished.'
  82       call ebend(ebe,ethetacnstr)
  83 cd    print *,'Bend energy finished.'
  84 C
  85 C Calculate the SC local energy.
  86 C
  87       call esc(escloc)
  88 C       print *,'SCLOC energy finished.'
  89 C
  90 C Calculate the virtual-bond torsional energy.
  91 C
  92 cd    print *,'nterm=',nterm
  93       call etor(etors,edihcnstr,fact(1))
  94 C
  95 C 6/23/01 Calculate double-torsional energy
  96 C
  97       call etor_d(etors_d,fact(2))
  98 C
  99 C 21/5/07 Calculate local sicdechain correlation energy
 100 C
 101       call eback_sc_corr(esccor)
 102
 103       if (wliptran.gt.0) then
 104         call Eliptransfer(eliptran)
 105       endif
 106
 107 C
 108 C 12/1/95 Multi-body terms
 109 C
 110       n_corr=0
 111       n_corr1=0
 112       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 113      &    .or. wturn6.gt.0.0d0) then
 114 c         print *,"calling multibody_eello"
 115          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 116 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 117 c         print *,ecorr,ecorr5,ecorr6,eturn6
 118       else
 119          ecorr=0.0d0
 120          ecorr5=0.0d0
 121          ecorr6=0.0d0
 122          eturn6=0.0d0
 123       endif
 124       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 125          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 126       endif
 127 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 128 #ifdef SPLITELE
 129       if (shield_mode.gt.0) then
 130       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 131      & +welec*fact(1)*ees
 132      & +fact(1)*wvdwpp*evdw1
 133      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 134      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 135      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 136      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 137      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 138      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 139      & +wliptran*eliptran
 140       else
 141       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 142      & +wvdwpp*evdw1
 143      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 144      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 145      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 146      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 147      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 148      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 149      & +wliptran*eliptran
 150       endif
 151 #else
 152       if (shield_mode.gt.0) then
 153       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 154      & +welec*fact(1)*(ees+evdw1)
 155      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 156      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 157      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 158      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 159      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 160      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 161      & +wliptran*eliptran
 162       else
 163       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 164      & +welec*fact(1)*(ees+evdw1)
 165      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 166      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 167      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 168      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 169      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 170      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 171      & +wliptran*eliptran
 172       endif
 173 #endif
 174       energia(0)=etot
 175       energia(1)=evdw
 176 #ifdef SCP14
 177       energia(2)=evdw2-evdw2_14
 178       energia(17)=evdw2_14
 179 #else
 180       energia(2)=evdw2
 181       energia(17)=0.0d0
 182 #endif
 183 #ifdef SPLITELE
 184       energia(3)=ees
 185       energia(16)=evdw1
 186 #else
 187       energia(3)=ees+evdw1
 188       energia(16)=0.0d0
 189 #endif
 190       energia(4)=ecorr
 191       energia(5)=ecorr5
 192       energia(6)=ecorr6
 193       energia(7)=eel_loc
 194       energia(8)=eello_turn3
 195       energia(9)=eello_turn4
 196       energia(10)=eturn6
 197       energia(11)=ebe
 198       energia(12)=escloc
 199       energia(13)=etors
 200       energia(14)=etors_d
 201       energia(15)=ehpb
 202       energia(18)=estr
 203       energia(19)=esccor
 204       energia(20)=edihcnstr
 205       energia(21)=evdw_t
 206       energia(24)=ethetacnstr
 207       energia(22)=eliptran
 208 c detecting NaNQ
 209 #ifdef ISNAN
 210 #ifdef AIX
 211       if (isnan(etot).ne.0) energia(0)=1.0d+99
 212 #else
 213       if (isnan(etot)) energia(0)=1.0d+99
 214 #endif
 215 #else
 216       i=0
 217 #ifdef WINPGI
 218       idumm=proc_proc(etot,i)
 219 #else
 220       call proc_proc(etot,i)
 221 #endif
 222       if(i.eq.1)energia(0)=1.0d+99
 223 #endif
 224 #ifdef MPL
 225 c     endif
 226 #endif
 227 #define DEBUG
 228 #ifdef DEBUG
 229       call enerprint(energia,fact)
 230 #endif
 231 #undef DEBUG
 232       if (calc_grad) then
 233 C
 234 C Sum up the components of the Cartesian gradient.
 235 C
 236 #ifdef SPLITELE
 237       do i=1,nct
 238         do j=1,3
 239       if (shield_mode.eq.0) then
 240           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 241      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 242      &                wbond*gradb(j,i)+
 243      &                wstrain*ghpbc(j,i)+
 244      &                wcorr*fact(3)*gradcorr(j,i)+
 245      &                wel_loc*fact(2)*gel_loc(j,i)+
 246      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 247      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 248      &                wcorr5*fact(4)*gradcorr5(j,i)+
 249      &                wcorr6*fact(5)*gradcorr6(j,i)+
 250      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 251      &                wsccor*fact(2)*gsccorc(j,i)
 252      &               +wliptran*gliptranc(j,i)
 253      &                 +welec*gshieldc(j,i)
 254      &                 +welec*gshieldc_loc(j,i)
 255      &                 +wcorr*gshieldc_ec(j,i)
 256      &                 +wcorr*gshieldc_loc_ec(j,i)
 257      &                 +wturn3*gshieldc_t3(j,i)
 258      &                 +wturn3*gshieldc_loc_t3(j,i)
 259      &                 +wturn4*gshieldc_t4(j,i)
 260      &                 +wturn4*gshieldc_loc_t4(j,i)
 261      &                 +wel_loc*gshieldc_ll(j,i)
 262      &                 +wel_loc*gshieldc_loc_ll(j,i)
 263
 264           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 265      &                  wbond*gradbx(j,i)+
 266      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 267      &                  wsccor*fact(2)*gsccorx(j,i)
 268      &                 +wliptran*gliptranx(j,i)
 269      &                 +welec*gshieldx(j,i)
 270      &                 +wcorr*gshieldx_ec(j,i)
 271      &                 +wturn3*gshieldx_t3(j,i)
 272      &                 +wturn4*gshieldx_t4(j,i)
 273      &                 +wel_loc*gshieldx_ll(j,i)
 274
 275         else
 276           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 277      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 278      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 279      &                wbond*gradb(j,i)+
 280      &                wstrain*ghpbc(j,i)+
 281      &                wcorr*fact(3)*gradcorr(j,i)+
 282      &                wel_loc*fact(2)*gel_loc(j,i)+
 283      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 284      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 285      &                wcorr5*fact(4)*gradcorr5(j,i)+
 286      &                wcorr6*fact(5)*gradcorr6(j,i)+
 287      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 288      &                wsccor*fact(2)*gsccorc(j,i)
 289      &               +wliptran*gliptranc(j,i)
 290      &                 +welec*gshieldc(j,i)
 291      &                 +welec*gshieldc_loc(j,i)
 292      &                 +wcorr*gshieldc_ec(j,i)
 293      &                 +wcorr*gshieldc_loc_ec(j,i)
 294      &                 +wturn3*gshieldc_t3(j,i)
 295      &                 +wturn3*gshieldc_loc_t3(j,i)
 296      &                 +wturn4*gshieldc_t4(j,i)
 297      &                 +wturn4*gshieldc_loc_t4(j,i)
 298      &                 +wel_loc*gshieldc_ll(j,i)
 299      &                 +wel_loc*gshieldc_loc_ll(j,i)
 300
 301           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 302      &                 +fact(1)*wscp*gradx_scp(j,i)+
 303      &                  wbond*gradbx(j,i)+
 304      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 305      &                  wsccor*fact(2)*gsccorx(j,i)
 306      &                 +wliptran*gliptranx(j,i)
 307      &                 +welec*gshieldx(j,i)
 308      &                 +wcorr*gshieldx_ec(j,i)
 309      &                 +wturn3*gshieldx_t3(j,i)
 310      &                 +wturn4*gshieldx_t4(j,i)
 311      &                 +wel_loc*gshieldx_ll(j,i)
 312
 313
 314         endif
 315         enddo
 316 #else
 317       do i=1,nct
 318         do j=1,3
 319                 if (shield_mode.eq.0) then
 320           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 321      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 322      &                wbond*gradb(j,i)+
 323      &                wcorr*fact(3)*gradcorr(j,i)+
 324      &                wel_loc*fact(2)*gel_loc(j,i)+
 325      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 326      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 327      &                wcorr5*fact(4)*gradcorr5(j,i)+
 328      &                wcorr6*fact(5)*gradcorr6(j,i)+
 329      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 330      &                wsccor*fact(2)*gsccorc(j,i)
 331      &               +wliptran*gliptranc(j,i)
 332      &                 +welec*gshieldc(j,i)
 333      &                 +welec*gshieldc_loc(j,i)
 334      &                 +wcorr*gshieldc_ec(j,i)
 335      &                 +wcorr*gshieldc_loc_ec(j,i)
 336      &                 +wturn3*gshieldc_t3(j,i)
 337      &                 +wturn3*gshieldc_loc_t3(j,i)
 338      &                 +wturn4*gshieldc_t4(j,i)
 339      &                 +wturn4*gshieldc_loc_t4(j,i)
 340      &                 +wel_loc*gshieldc_ll(j,i)
 341      &                 +wel_loc*gshieldc_loc_ll(j,i)
 342
 343           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 344      &                  wbond*gradbx(j,i)+
 345      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 346      &                  wsccor*fact(1)*gsccorx(j,i)
 347      &                 +wliptran*gliptranx(j,i)
 348      &                 +welec*gshieldx(j,i)
 349      &                 +wcorr*gshieldx_ec(j,i)
 350      &                 +wturn3*gshieldx_t3(j,i)
 351      &                 +wturn4*gshieldx_t4(j,i)
 352      &                 +wel_loc*gshieldx_ll(j,i)
 353
 354               else
 355           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 356      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 357      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 358      &                wbond*gradb(j,i)+
 359      &                wcorr*fact(3)*gradcorr(j,i)+
 360      &                wel_loc*fact(2)*gel_loc(j,i)+
 361      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 362      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 363      &                wcorr5*fact(4)*gradcorr5(j,i)+
 364      &                wcorr6*fact(5)*gradcorr6(j,i)+
 365      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 366      &                wsccor*fact(2)*gsccorc(j,i)
 367      &               +wliptran*gliptranc(j,i)
 368      &                 +welec*gshieldc(j,i)
 369      &                 +welec*gshieldc_loc(j,i)
 370      &                 +wcorr*gshieldc_ec(j,i)
 371      &                 +wcorr*gshieldc_loc_ec(j,i)
 372      &                 +wturn3*gshieldc_t3(j,i)
 373      &                 +wturn3*gshieldc_loc_t3(j,i)
 374      &                 +wturn4*gshieldc_t4(j,i)
 375      &                 +wturn4*gshieldc_loc_t4(j,i)
 376      &                 +wel_loc*gshieldc_ll(j,i)
 377      &                 +wel_loc*gshieldc_loc_ll(j,i)
 378
 379           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 380      &                  fact(1)*wscp*gradx_scp(j,i)+
 381      &                  wbond*gradbx(j,i)+
 382      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 383      &                  wsccor*fact(1)*gsccorx(j,i)
 384      &                 +wliptran*gliptranx(j,i)
 385      &                 +welec*gshieldx(j,i)
 386      &                 +wcorr*gshieldx_ec(j,i)
 387      &                 +wturn3*gshieldx_t3(j,i)
 388      &                 +wturn4*gshieldx_t4(j,i)
 389      &                 +wel_loc*gshieldx_ll(j,i)
 390
 391          endif
 392         enddo
 393 #endif
 394       enddo
 395
 396
 397       do i=1,nres-3
 398         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 399      &   +wcorr5*fact(4)*g_corr5_loc(i)
 400      &   +wcorr6*fact(5)*g_corr6_loc(i)
 401      &   +wturn4*fact(3)*gel_loc_turn4(i)
 402      &   +wturn3*fact(2)*gel_loc_turn3(i)
 403      &   +wturn6*fact(5)*gel_loc_turn6(i)
 404      &   +wel_loc*fact(2)*gel_loc_loc(i)
 405 c     &   +wsccor*fact(1)*gsccor_loc(i)
 406 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 407       enddo
 408       endif
 409       if (dyn_ss) call dyn_set_nss
 410       return
 411       end
 412 C------------------------------------------------------------------------
 413       subroutine enerprint(energia,fact)
 414       implicit real*8 (a-h,o-z)
 415       include 'DIMENSIONS'
 416       include 'DIMENSIONS.ZSCOPT'
 417       include 'COMMON.IOUNITS'
 418       include 'COMMON.FFIELD'
 419       include 'COMMON.SBRIDGE'
 420       double precision energia(0:max_ene),fact(6)
 421       etot=energia(0)
 422       evdw=energia(1)+fact(6)*energia(21)
 423 #ifdef SCP14
 424       evdw2=energia(2)+energia(17)
 425 #else
 426       evdw2=energia(2)
 427 #endif
 428       ees=energia(3)
 429 #ifdef SPLITELE
 430       evdw1=energia(16)
 431 #endif
 432       ecorr=energia(4)
 433       ecorr5=energia(5)
 434       ecorr6=energia(6)
 435       eel_loc=energia(7)
 436       eello_turn3=energia(8)
 437       eello_turn4=energia(9)
 438       eello_turn6=energia(10)
 439       ebe=energia(11)
 440       escloc=energia(12)
 441       etors=energia(13)
 442       etors_d=energia(14)
 443       ehpb=energia(15)
 444       esccor=energia(19)
 445       edihcnstr=energia(20)
 446       estr=energia(18)
 447       ethetacnstr=energia(24)
 448       eliptran=energia(22)
 449 #ifdef SPLITELE
 450       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 451      &  wvdwpp,
 452      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 453      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 454      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 455      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 456      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 457      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 458      & eliptran,wliptran,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 elec)'/
 463      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 464      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 465      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 466      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 467      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 468      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 469      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 470      & ' (SS bridges & dist. cnstr.)'/
 471      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 472      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 473      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 474      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 475      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 476      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 477      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 478      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 479      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 480      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 481      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 482      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 483      & 'ETOT=  ',1pE16.6,' (total)')
 484 #else
 485       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 486      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 487      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 488      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 489      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 490      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 491      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 492    10 format (/'Virtual-chain energies:'//
 493      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 494      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 495      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 496      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 497      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 498      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 499      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 500      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 501      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 502      & ' (SS bridges & dist. cnstr.)'/
 503      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 504      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 505      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 506      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 507      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 508      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 509      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 510      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 511      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 512      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 513      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 514      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 515      & 'ETOT=  ',1pE16.6,' (total)')
 516 #endif
 517       return
 518       end
 519 C-----------------------------------------------------------------------
 520       subroutine elj(evdw,evdw_t)
 521 C
 522 C This subroutine calculates the interaction energy of nonbonded side chains
 523 C assuming the LJ potential of interaction.
 524 C
 525       implicit real*8 (a-h,o-z)
 526       include 'DIMENSIONS'
 527       include 'DIMENSIONS.ZSCOPT'
 528       include "DIMENSIONS.COMPAR"
 529       parameter (accur=1.0d-10)
 530       include 'COMMON.GEO'
 531       include 'COMMON.VAR'
 532       include 'COMMON.LOCAL'
 533       include 'COMMON.CHAIN'
 534       include 'COMMON.DERIV'
 535       include 'COMMON.INTERACT'
 536       include 'COMMON.TORSION'
 537       include 'COMMON.ENEPS'
 538       include 'COMMON.SBRIDGE'
 539       include 'COMMON.NAMES'
 540       include 'COMMON.IOUNITS'
 541       include 'COMMON.CONTACTS'
 542       dimension gg(3)
 543       integer icant
 544       external icant
 545 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 546 c ROZNICA z cluster
 547       do i=1,210
 548         do j=1,2
 549           eneps_temp(j,i)=0.0d0
 550         enddo
 551       enddo
 552 cROZNICA
 553
 554       evdw=0.0D0
 555       evdw_t=0.0d0
 556       do i=iatsc_s,iatsc_e
 557         itypi=iabs(itype(i))
 558         if (itypi.eq.ntyp1) cycle
 559         itypi1=iabs(itype(i+1))
 560         xi=c(1,nres+i)
 561         yi=c(2,nres+i)
 562         zi=c(3,nres+i)
 563 C Change 12/1/95
 564         num_conti=0
 565 C
 566 C Calculate SC interaction energy.
 567 C
 568         do iint=1,nint_gr(i)
 569 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 570 cd   &                  'iend=',iend(i,iint)
 571           do j=istart(i,iint),iend(i,iint)
 572             itypj=iabs(itype(j))
 573             if (itypj.eq.ntyp1) cycle
 574             xj=c(1,nres+j)-xi
 575             yj=c(2,nres+j)-yi
 576             zj=c(3,nres+j)-zi
 577 C Change 12/1/95 to calculate four-body interactions
 578             rij=xj*xj+yj*yj+zj*zj
 579             rrij=1.0D0/rij
 580 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 581             eps0ij=eps(itypi,itypj)
 582             fac=rrij**expon2
 583             e1=fac*fac*aa
 584             e2=fac*bb
 585             evdwij=e1+e2
 586             ij=icant(itypi,itypj)
 587 c ROZNICA z cluster
 588             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 589             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 590 c
 591
 592 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 593 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 594 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 595 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 596 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 597 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 598             if (bb.gt.0.0d0) then
 599               evdw=evdw+evdwij
 600             else
 601               evdw_t=evdw_t+evdwij
 602             endif
 603             if (calc_grad) then
 604 C
 605 C Calculate the components of the gradient in DC and X
 606 C
 607             fac=-rrij*(e1+evdwij)
 608             gg(1)=xj*fac
 609             gg(2)=yj*fac
 610             gg(3)=zj*fac
 611             do k=1,3
 612               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 613               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 614             enddo
 615             do k=i,j-1
 616               do l=1,3
 617                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 618               enddo
 619             enddo
 620             endif
 621 C
 622 C 12/1/95, revised on 5/20/97
 623 C
 624 C Calculate the contact function. The ith column of the array JCONT will
 625 C contain the numbers of atoms that make contacts with the atom I (of numbers
 626 C greater than I). The arrays FACONT and GACONT will contain the values of
 627 C the contact function and its derivative.
 628 C
 629 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 630 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 631 C Uncomment next line, if the correlation interactions are contact function only
 632             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 633               rij=dsqrt(rij)
 634               sigij=sigma(itypi,itypj)
 635               r0ij=rs0(itypi,itypj)
 636 C
 637 C Check whether the SC's are not too far to make a contact.
 638 C
 639               rcut=1.5d0*r0ij
 640               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 641 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 642 C
 643               if (fcont.gt.0.0D0) then
 644 C If the SC-SC distance if close to sigma, apply spline.
 645 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 646 cAdam &             fcont1,fprimcont1)
 647 cAdam           fcont1=1.0d0-fcont1
 648 cAdam           if (fcont1.gt.0.0d0) then
 649 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 650 cAdam             fcont=fcont*fcont1
 651 cAdam           endif
 652 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 653 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 654 cga             do k=1,3
 655 cga               gg(k)=gg(k)*eps0ij
 656 cga             enddo
 657 cga             eps0ij=-evdwij*eps0ij
 658 C Uncomment for AL's type of SC correlation interactions.
 659 cadam           eps0ij=-evdwij
 660                 num_conti=num_conti+1
 661                 jcont(num_conti,i)=j
 662                 facont(num_conti,i)=fcont*eps0ij
 663                 fprimcont=eps0ij*fprimcont/rij
 664                 fcont=expon*fcont
 665 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 666 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 667 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 668 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 669                 gacont(1,num_conti,i)=-fprimcont*xj
 670                 gacont(2,num_conti,i)=-fprimcont*yj
 671                 gacont(3,num_conti,i)=-fprimcont*zj
 672 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 673 cd              write (iout,'(2i3,3f10.5)')
 674 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 675               endif
 676             endif
 677           enddo      ! j
 678         enddo        ! iint
 679 C Change 12/1/95
 680         num_cont(i)=num_conti
 681       enddo          ! i
 682       if (calc_grad) then
 683       do i=1,nct
 684         do j=1,3
 685           gvdwc(j,i)=expon*gvdwc(j,i)
 686           gvdwx(j,i)=expon*gvdwx(j,i)
 687         enddo
 688       enddo
 689       endif
 690 C******************************************************************************
 691 C
 692 C                              N O T E !!!
 693 C
 694 C To save time, the factor of EXPON has been extracted from ALL components
 695 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 696 C use!
 697 C
 698 C******************************************************************************
 699       return
 700       end
 701 C-----------------------------------------------------------------------------
 702       subroutine eljk(evdw,evdw_t)
 703 C
 704 C This subroutine calculates the interaction energy of nonbonded side chains
 705 C assuming the LJK potential of interaction.
 706 C
 707       implicit real*8 (a-h,o-z)
 708       include 'DIMENSIONS'
 709       include 'DIMENSIONS.ZSCOPT'
 710       include "DIMENSIONS.COMPAR"
 711       include 'COMMON.GEO'
 712       include 'COMMON.VAR'
 713       include 'COMMON.LOCAL'
 714       include 'COMMON.CHAIN'
 715       include 'COMMON.DERIV'
 716       include 'COMMON.INTERACT'
 717       include 'COMMON.ENEPS'
 718       include 'COMMON.IOUNITS'
 719       include 'COMMON.NAMES'
 720       dimension gg(3)
 721       logical scheck
 722       integer icant
 723       external icant
 724 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 725       do i=1,210
 726         do j=1,2
 727           eneps_temp(j,i)=0.0d0
 728         enddo
 729       enddo
 730       evdw=0.0D0
 731       evdw_t=0.0d0
 732       do i=iatsc_s,iatsc_e
 733         itypi=iabs(itype(i))
 734         if (itypi.eq.ntyp1) cycle
 735         itypi1=iabs(itype(i+1))
 736         xi=c(1,nres+i)
 737         yi=c(2,nres+i)
 738         zi=c(3,nres+i)
 739 C
 740 C Calculate SC interaction energy.
 741 C
 742         do iint=1,nint_gr(i)
 743           do j=istart(i,iint),iend(i,iint)
 744             itypj=iabs(itype(j))
 745             if (itypj.eq.ntyp1) cycle
 746             xj=c(1,nres+j)-xi
 747             yj=c(2,nres+j)-yi
 748             zj=c(3,nres+j)-zi
 749             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 750             fac_augm=rrij**expon
 751             e_augm=augm(itypi,itypj)*fac_augm
 752             r_inv_ij=dsqrt(rrij)
 753             rij=1.0D0/r_inv_ij
 754             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 755             fac=r_shift_inv**expon
 756             e1=fac*fac*aa
 757             e2=fac*bb
 758             evdwij=e_augm+e1+e2
 759             ij=icant(itypi,itypj)
 760             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 761      &        /dabs(eps(itypi,itypj))
 762             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 763 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 764 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 765 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 766 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 767 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 768 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 769 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 770             if (bb.gt.0.0d0) then
 771               evdw=evdw+evdwij
 772             else
 773               evdw_t=evdw_t+evdwij
 774             endif
 775             if (calc_grad) then
 776 C
 777 C Calculate the components of the gradient in DC and X
 778 C
 779             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 780             gg(1)=xj*fac
 781             gg(2)=yj*fac
 782             gg(3)=zj*fac
 783             do k=1,3
 784               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 785               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 786             enddo
 787             do k=i,j-1
 788               do l=1,3
 789                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 790               enddo
 791             enddo
 792             endif
 793           enddo      ! j
 794         enddo        ! iint
 795       enddo          ! i
 796       if (calc_grad) then
 797       do i=1,nct
 798         do j=1,3
 799           gvdwc(j,i)=expon*gvdwc(j,i)
 800           gvdwx(j,i)=expon*gvdwx(j,i)
 801         enddo
 802       enddo
 803       endif
 804       return
 805       end
 806 C-----------------------------------------------------------------------------
 807       subroutine ebp(evdw,evdw_t)
 808 C
 809 C This subroutine calculates the interaction energy of nonbonded side chains
 810 C assuming the Berne-Pechukas potential of interaction.
 811 C
 812       implicit real*8 (a-h,o-z)
 813       include 'DIMENSIONS'
 814       include 'DIMENSIONS.ZSCOPT'
 815       include "DIMENSIONS.COMPAR"
 816       include 'COMMON.GEO'
 817       include 'COMMON.VAR'
 818       include 'COMMON.LOCAL'
 819       include 'COMMON.CHAIN'
 820       include 'COMMON.DERIV'
 821       include 'COMMON.NAMES'
 822       include 'COMMON.INTERACT'
 823       include 'COMMON.ENEPS'
 824       include 'COMMON.IOUNITS'
 825       include 'COMMON.CALC'
 826       common /srutu/ icall
 827 c     double precision rrsave(maxdim)
 828       logical lprn
 829       integer icant
 830       external icant
 831       do i=1,210
 832         do j=1,2
 833           eneps_temp(j,i)=0.0d0
 834         enddo
 835       enddo
 836       evdw=0.0D0
 837       evdw_t=0.0d0
 838 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 839 c     if (icall.eq.0) then
 840 c       lprn=.true.
 841 c     else
 842         lprn=.false.
 843 c     endif
 844       ind=0
 845       do i=iatsc_s,iatsc_e
 846         itypi=iabs(itype(i))
 847         if (itypi.eq.ntyp1) cycle
 848         itypi1=iabs(itype(i+1))
 849         xi=c(1,nres+i)
 850         yi=c(2,nres+i)
 851         zi=c(3,nres+i)
 852         dxi=dc_norm(1,nres+i)
 853         dyi=dc_norm(2,nres+i)
 854         dzi=dc_norm(3,nres+i)
 855         dsci_inv=vbld_inv(i+nres)
 856 C
 857 C Calculate SC interaction energy.
 858 C
 859         do iint=1,nint_gr(i)
 860           do j=istart(i,iint),iend(i,iint)
 861             ind=ind+1
 862             itypj=iabs(itype(j))
 863             if (itypj.eq.ntyp1) cycle
 864             dscj_inv=vbld_inv(j+nres)
 865             chi1=chi(itypi,itypj)
 866             chi2=chi(itypj,itypi)
 867             chi12=chi1*chi2
 868             chip1=chip(itypi)
 869             chip2=chip(itypj)
 870             chip12=chip1*chip2
 871             alf1=alp(itypi)
 872             alf2=alp(itypj)
 873             alf12=0.5D0*(alf1+alf2)
 874 C For diagnostics only!!!
 875 c           chi1=0.0D0
 876 c           chi2=0.0D0
 877 c           chi12=0.0D0
 878 c           chip1=0.0D0
 879 c           chip2=0.0D0
 880 c           chip12=0.0D0
 881 c           alf1=0.0D0
 882 c           alf2=0.0D0
 883 c           alf12=0.0D0
 884             xj=c(1,nres+j)-xi
 885             yj=c(2,nres+j)-yi
 886             zj=c(3,nres+j)-zi
 887             dxj=dc_norm(1,nres+j)
 888             dyj=dc_norm(2,nres+j)
 889             dzj=dc_norm(3,nres+j)
 890             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 891 cd          if (icall.eq.0) then
 892 cd            rrsave(ind)=rrij
 893 cd          else
 894 cd            rrij=rrsave(ind)
 895 cd          endif
 896             rij=dsqrt(rrij)
 897 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 898             call sc_angular
 899 C Calculate whole angle-dependent part of epsilon and contributions
 900 C to its derivatives
 901             fac=(rrij*sigsq)**expon2
 902             e1=fac*fac*aa
 903             e2=fac*bb
 904             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 905             eps2der=evdwij*eps3rt
 906             eps3der=evdwij*eps2rt
 907             evdwij=evdwij*eps2rt*eps3rt
 908             ij=icant(itypi,itypj)
 909             aux=eps1*eps2rt**2*eps3rt**2
 910             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 911      &        /dabs(eps(itypi,itypj))
 912             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 913             if (bb.gt.0.0d0) then
 914               evdw=evdw+evdwij
 915             else
 916               evdw_t=evdw_t+evdwij
 917             endif
 918             if (calc_grad) then
 919             if (lprn) then
 920             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 921             epsi=bb**2/aa
 922             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 923      &        restyp(itypi),i,restyp(itypj),j,
 924      &        epsi,sigm,chi1,chi2,chip1,chip2,
 925      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 926      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 927      &        evdwij
 928             endif
 929 C Calculate gradient components.
 930             e1=e1*eps1*eps2rt**2*eps3rt**2
 931             fac=-expon*(e1+evdwij)
 932             sigder=fac/sigsq
 933             fac=rrij*fac
 934 C Calculate radial part of the gradient
 935             gg(1)=xj*fac
 936             gg(2)=yj*fac
 937             gg(3)=zj*fac
 938 C Calculate the angular part of the gradient and sum add the contributions
 939 C to the appropriate components of the Cartesian gradient.
 940             call sc_grad
 941             endif
 942           enddo      ! j
 943         enddo        ! iint
 944       enddo          ! i
 945 c     stop
 946       return
 947       end
 948 C-----------------------------------------------------------------------------
 949       subroutine egb(evdw,evdw_t)
 950 C
 951 C This subroutine calculates the interaction energy of nonbonded side chains
 952 C assuming the Gay-Berne potential of interaction.
 953 C
 954       implicit real*8 (a-h,o-z)
 955       include 'DIMENSIONS'
 956       include 'DIMENSIONS.ZSCOPT'
 957       include "DIMENSIONS.COMPAR"
 958       include 'COMMON.GEO'
 959       include 'COMMON.VAR'
 960       include 'COMMON.LOCAL'
 961       include 'COMMON.CHAIN'
 962       include 'COMMON.DERIV'
 963       include 'COMMON.NAMES'
 964       include 'COMMON.INTERACT'
 965       include 'COMMON.ENEPS'
 966       include 'COMMON.IOUNITS'
 967       include 'COMMON.CALC'
 968       include 'COMMON.SBRIDGE'
 969       logical lprn
 970       common /srutu/icall
 971       integer icant,xshift,yshift,zshift
 972       external icant
 973       do i=1,210
 974         do j=1,2
 975           eneps_temp(j,i)=0.0d0
 976         enddo
 977       enddo
 978 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 979       evdw=0.0D0
 980       evdw_t=0.0d0
 981       lprn=.false.
 982 c      if (icall.gt.0) lprn=.true.
 983       ind=0
 984       do i=iatsc_s,iatsc_e
 985         itypi=iabs(itype(i))
 986         if (itypi.eq.ntyp1) cycle
 987         itypi1=iabs(itype(i+1))
 988         xi=c(1,nres+i)
 989         yi=c(2,nres+i)
 990         zi=c(3,nres+i)
 991 C returning the ith atom to box
 992           xi=mod(xi,boxxsize)
 993           if (xi.lt.0) xi=xi+boxxsize
 994           yi=mod(yi,boxysize)
 995           if (yi.lt.0) yi=yi+boxysize
 996           zi=mod(zi,boxzsize)
 997           if (zi.lt.0) zi=zi+boxzsize
 998        if ((zi.gt.bordlipbot)
 999      &.and.(zi.lt.bordliptop)) then
1000 C the energy transfer exist
1001         if (zi.lt.buflipbot) then
1002 C what fraction I am in
1003          fracinbuf=1.0d0-
1004      &        ((zi-bordlipbot)/lipbufthick)
1005 C lipbufthick is thickenes of lipid buffore
1006          sslipi=sscalelip(fracinbuf)
1007          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1008         elseif (zi.gt.bufliptop) then
1009          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1010          sslipi=sscalelip(fracinbuf)
1011          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1012         else
1013          sslipi=1.0d0
1014          ssgradlipi=0.0
1015         endif
1016        else
1017          sslipi=0.0d0
1018          ssgradlipi=0.0
1019        endif
1020
1021         dxi=dc_norm(1,nres+i)
1022         dyi=dc_norm(2,nres+i)
1023         dzi=dc_norm(3,nres+i)
1024         dsci_inv=vbld_inv(i+nres)
1025 C
1026 C Calculate SC interaction energy.
1027 C
1028         do iint=1,nint_gr(i)
1029           do j=istart(i,iint),iend(i,iint)
1030             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1031               call dyn_ssbond_ene(i,j,evdwij)
1032               evdw=evdw+evdwij
1033 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1034 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1035 C triple bond artifac removal
1036              do k=j+1,iend(i,iint)
1037 C search over all next residues
1038               if (dyn_ss_mask(k)) then
1039 C check if they are cysteins
1040 C              write(iout,*) 'k=',k
1041               call triple_ssbond_ene(i,j,k,evdwij)
1042 C call the energy function that removes the artifical triple disulfide
1043 C bond the soubroutine is located in ssMD.F
1044               evdw=evdw+evdwij
1045 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1046 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1047               endif!dyn_ss_mask(k)
1048              enddo! k
1049             ELSE
1050             ind=ind+1
1051             itypj=iabs(itype(j))
1052             if (itypj.eq.ntyp1) cycle
1053             dscj_inv=vbld_inv(j+nres)
1054             sig0ij=sigma(itypi,itypj)
1055             chi1=chi(itypi,itypj)
1056             chi2=chi(itypj,itypi)
1057             chi12=chi1*chi2
1058             chip1=chip(itypi)
1059             chip2=chip(itypj)
1060             chip12=chip1*chip2
1061             alf1=alp(itypi)
1062             alf2=alp(itypj)
1063             alf12=0.5D0*(alf1+alf2)
1064 C For diagnostics only!!!
1065 c           chi1=0.0D0
1066 c           chi2=0.0D0
1067 c           chi12=0.0D0
1068 c           chip1=0.0D0
1069 c           chip2=0.0D0
1070 c           chip12=0.0D0
1071 c           alf1=0.0D0
1072 c           alf2=0.0D0
1073 c           alf12=0.0D0
1074             xj=c(1,nres+j)
1075             yj=c(2,nres+j)
1076             zj=c(3,nres+j)
1077 C returning jth atom to box
1078           xj=mod(xj,boxxsize)
1079           if (xj.lt.0) xj=xj+boxxsize
1080           yj=mod(yj,boxysize)
1081           if (yj.lt.0) yj=yj+boxysize
1082           zj=mod(zj,boxzsize)
1083           if (zj.lt.0) zj=zj+boxzsize
1084        if ((zj.gt.bordlipbot)
1085      &.and.(zj.lt.bordliptop)) then
1086 C the energy transfer exist
1087         if (zj.lt.buflipbot) then
1088 C what fraction I am in
1089          fracinbuf=1.0d0-
1090      &        ((zj-bordlipbot)/lipbufthick)
1091 C lipbufthick is thickenes of lipid buffore
1092          sslipj=sscalelip(fracinbuf)
1093          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1094         elseif (zj.gt.bufliptop) then
1095          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1096          sslipj=sscalelip(fracinbuf)
1097          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1098         else
1099          sslipj=1.0d0
1100          ssgradlipj=0.0
1101         endif
1102        else
1103          sslipj=0.0d0
1104          ssgradlipj=0.0
1105        endif
1106       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1107      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1108       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1109      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1110 C       if (aa.ne.aa_aq(itypi,itypj)) then
1111
1112 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1113 C     & bb_aq(itypi,itypj)-bb,
1114 C     & sslipi,sslipj
1115 C         endif
1116
1117 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1118 C checking the distance
1119       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1120       xj_safe=xj
1121       yj_safe=yj
1122       zj_safe=zj
1123       subchap=0
1124 C finding the closest
1125       do xshift=-1,1
1126       do yshift=-1,1
1127       do zshift=-1,1
1128           xj=xj_safe+xshift*boxxsize
1129           yj=yj_safe+yshift*boxysize
1130           zj=zj_safe+zshift*boxzsize
1131           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1132           if(dist_temp.lt.dist_init) then
1133             dist_init=dist_temp
1134             xj_temp=xj
1135             yj_temp=yj
1136             zj_temp=zj
1137             subchap=1
1138           endif
1139        enddo
1140        enddo
1141        enddo
1142        if (subchap.eq.1) then
1143           xj=xj_temp-xi
1144           yj=yj_temp-yi
1145           zj=zj_temp-zi
1146        else
1147           xj=xj_safe-xi
1148           yj=yj_safe-yi
1149           zj=zj_safe-zi
1150        endif
1151
1152             dxj=dc_norm(1,nres+j)
1153             dyj=dc_norm(2,nres+j)
1154             dzj=dc_norm(3,nres+j)
1155 c            write (iout,*) i,j,xj,yj,zj
1156             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1157             rij=dsqrt(rrij)
1158             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1159             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1160             if (sss.le.0.0) cycle
1161 C Calculate angle-dependent terms of energy and contributions to their
1162 C derivatives.
1163
1164             call sc_angular
1165             sigsq=1.0D0/sigsq
1166             sig=sig0ij*dsqrt(sigsq)
1167             rij_shift=1.0D0/rij-sig+sig0ij
1168 C I hate to put IF's in the loops, but here don't have another choice!!!!
1169             if (rij_shift.le.0.0D0) then
1170               evdw=1.0D20
1171               return
1172             endif
1173             sigder=-sig*sigsq
1174 c---------------------------------------------------------------
1175             rij_shift=1.0D0/rij_shift
1176             fac=rij_shift**expon
1177             e1=fac*fac*aa
1178             e2=fac*bb
1179             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1180             eps2der=evdwij*eps3rt
1181             eps3der=evdwij*eps2rt
1182             evdwij=evdwij*eps2rt*eps3rt
1183             if (bb.gt.0) then
1184               evdw=evdw+evdwij*sss
1185             else
1186               evdw_t=evdw_t+evdwij*sss
1187             endif
1188             ij=icant(itypi,itypj)
1189             aux=eps1*eps2rt**2*eps3rt**2
1190             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1191      &        /dabs(eps(itypi,itypj))
1192             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1193 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1194 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1195 c     &         aux*e2/eps(itypi,itypj)
1196 c            if (lprn) then
1197             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1198             epsi=bb**2/aa
1199 C#define DEBUG
1200 #ifdef DEBUG
1201             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1202      &        restyp(itypi),i,restyp(itypj),j,
1203      &        epsi,sigm,chi1,chi2,chip1,chip2,
1204      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1205      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1206      &        evdwij
1207              write (iout,*) "partial sum", evdw, evdw_t
1208 #endif
1209 C#undef DEBUG
1210 c            endif
1211             if (calc_grad) then
1212 C Calculate gradient components.
1213             e1=e1*eps1*eps2rt**2*eps3rt**2
1214             fac=-expon*(e1+evdwij)*rij_shift
1215             sigder=fac*sigder
1216             fac=rij*fac
1217             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1218 C Calculate the radial part of the gradient
1219             gg(1)=xj*fac
1220             gg(2)=yj*fac
1221             gg(3)=zj*fac
1222 C Calculate angular part of the gradient.
1223             call sc_grad
1224             endif
1225 C            write(iout,*)  "partial sum", evdw, evdw_t
1226             ENDIF    ! dyn_ss
1227           enddo      ! j
1228         enddo        ! iint
1229       enddo          ! i
1230       return
1231       end
1232 C-----------------------------------------------------------------------------
1233       subroutine egbv(evdw,evdw_t)
1234 C
1235 C This subroutine calculates the interaction energy of nonbonded side chains
1236 C assuming the Gay-Berne-Vorobjev potential of interaction.
1237 C
1238       implicit real*8 (a-h,o-z)
1239       include 'DIMENSIONS'
1240       include 'DIMENSIONS.ZSCOPT'
1241       include "DIMENSIONS.COMPAR"
1242       include 'COMMON.GEO'
1243       include 'COMMON.VAR'
1244       include 'COMMON.LOCAL'
1245       include 'COMMON.CHAIN'
1246       include 'COMMON.DERIV'
1247       include 'COMMON.NAMES'
1248       include 'COMMON.INTERACT'
1249       include 'COMMON.ENEPS'
1250       include 'COMMON.IOUNITS'
1251       include 'COMMON.CALC'
1252       common /srutu/ icall
1253       logical lprn
1254       integer icant
1255       external icant
1256       do i=1,210
1257         do j=1,2
1258           eneps_temp(j,i)=0.0d0
1259         enddo
1260       enddo
1261       evdw=0.0D0
1262       evdw_t=0.0d0
1263 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1264       evdw=0.0D0
1265       lprn=.false.
1266 c      if (icall.gt.0) lprn=.true.
1267       ind=0
1268       do i=iatsc_s,iatsc_e
1269         itypi=iabs(itype(i))
1270         if (itypi.eq.ntyp1) cycle
1271         itypi1=iabs(itype(i+1))
1272         xi=c(1,nres+i)
1273         yi=c(2,nres+i)
1274         zi=c(3,nres+i)
1275         dxi=dc_norm(1,nres+i)
1276         dyi=dc_norm(2,nres+i)
1277         dzi=dc_norm(3,nres+i)
1278         dsci_inv=vbld_inv(i+nres)
1279 C
1280 C Calculate SC interaction energy.
1281 C
1282         do iint=1,nint_gr(i)
1283           do j=istart(i,iint),iend(i,iint)
1284             ind=ind+1
1285             itypj=iabs(itype(j))
1286             if (itypj.eq.ntyp1) cycle
1287             dscj_inv=vbld_inv(j+nres)
1288             sig0ij=sigma(itypi,itypj)
1289             r0ij=r0(itypi,itypj)
1290             chi1=chi(itypi,itypj)
1291             chi2=chi(itypj,itypi)
1292             chi12=chi1*chi2
1293             chip1=chip(itypi)
1294             chip2=chip(itypj)
1295             chip12=chip1*chip2
1296             alf1=alp(itypi)
1297             alf2=alp(itypj)
1298             alf12=0.5D0*(alf1+alf2)
1299 C For diagnostics only!!!
1300 c           chi1=0.0D0
1301 c           chi2=0.0D0
1302 c           chi12=0.0D0
1303 c           chip1=0.0D0
1304 c           chip2=0.0D0
1305 c           chip12=0.0D0
1306 c           alf1=0.0D0
1307 c           alf2=0.0D0
1308 c           alf12=0.0D0
1309             xj=c(1,nres+j)-xi
1310             yj=c(2,nres+j)-yi
1311             zj=c(3,nres+j)-zi
1312             dxj=dc_norm(1,nres+j)
1313             dyj=dc_norm(2,nres+j)
1314             dzj=dc_norm(3,nres+j)
1315             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1316             rij=dsqrt(rrij)
1317 C Calculate angle-dependent terms of energy and contributions to their
1318 C derivatives.
1319             call sc_angular
1320             sigsq=1.0D0/sigsq
1321             sig=sig0ij*dsqrt(sigsq)
1322             rij_shift=1.0D0/rij-sig+r0ij
1323 C I hate to put IF's in the loops, but here don't have another choice!!!!
1324             if (rij_shift.le.0.0D0) then
1325               evdw=1.0D20
1326               return
1327             endif
1328             sigder=-sig*sigsq
1329 c---------------------------------------------------------------
1330             rij_shift=1.0D0/rij_shift
1331             fac=rij_shift**expon
1332             e1=fac*fac*aa
1333             e2=fac*bb
1334             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1335             eps2der=evdwij*eps3rt
1336             eps3der=evdwij*eps2rt
1337             fac_augm=rrij**expon
1338             e_augm=augm(itypi,itypj)*fac_augm
1339             evdwij=evdwij*eps2rt*eps3rt
1340             if (bb.gt.0.0d0) then
1341               evdw=evdw+evdwij+e_augm
1342             else
1343               evdw_t=evdw_t+evdwij+e_augm
1344             endif
1345             ij=icant(itypi,itypj)
1346             aux=eps1*eps2rt**2*eps3rt**2
1347             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1348      &        /dabs(eps(itypi,itypj))
1349             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1350 c            eneps_temp(ij)=eneps_temp(ij)
1351 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1352 c            if (lprn) then
1353 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1354 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1355 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1356 c     &        restyp(itypi),i,restyp(itypj),j,
1357 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1358 c     &        chi1,chi2,chip1,chip2,
1359 c     &        eps1,eps2rt**2,eps3rt**2,
1360 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1361 c     &        evdwij+e_augm
1362 c            endif
1363             if (calc_grad) then
1364 C Calculate gradient components.
1365             e1=e1*eps1*eps2rt**2*eps3rt**2
1366             fac=-expon*(e1+evdwij)*rij_shift
1367             sigder=fac*sigder
1368             fac=rij*fac-2*expon*rrij*e_augm
1369 C Calculate the radial part of the gradient
1370             gg(1)=xj*fac
1371             gg(2)=yj*fac
1372             gg(3)=zj*fac
1373 C Calculate angular part of the gradient.
1374             call sc_grad
1375             endif
1376           enddo      ! j
1377         enddo        ! iint
1378       enddo          ! i
1379       return
1380       end
1381 C-----------------------------------------------------------------------------
1382       subroutine sc_angular
1383 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1384 C om12. Called by ebp, egb, and egbv.
1385       implicit none
1386       include 'COMMON.CALC'
1387       erij(1)=xj*rij
1388       erij(2)=yj*rij
1389       erij(3)=zj*rij
1390       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1391       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1392       om12=dxi*dxj+dyi*dyj+dzi*dzj
1393       chiom12=chi12*om12
1394 C Calculate eps1(om12) and its derivative in om12
1395       faceps1=1.0D0-om12*chiom12
1396       faceps1_inv=1.0D0/faceps1
1397       eps1=dsqrt(faceps1_inv)
1398 C Following variable is eps1*deps1/dom12
1399       eps1_om12=faceps1_inv*chiom12
1400 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1401 C and om12.
1402       om1om2=om1*om2
1403       chiom1=chi1*om1
1404       chiom2=chi2*om2
1405       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1406       sigsq=1.0D0-facsig*faceps1_inv
1407       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1408       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1409       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1410 C Calculate eps2 and its derivatives in om1, om2, and om12.
1411       chipom1=chip1*om1
1412       chipom2=chip2*om2
1413       chipom12=chip12*om12
1414       facp=1.0D0-om12*chipom12
1415       facp_inv=1.0D0/facp
1416       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1417 C Following variable is the square root of eps2
1418       eps2rt=1.0D0-facp1*facp_inv
1419 C Following three variables are the derivatives of the square root of eps
1420 C in om1, om2, and om12.
1421       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1422       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1423       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1424 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1425       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1426 C Calculate whole angle-dependent part of epsilon and contributions
1427 C to its derivatives
1428       return
1429       end
1430 C----------------------------------------------------------------------------
1431       subroutine sc_grad
1432       implicit real*8 (a-h,o-z)
1433       include 'DIMENSIONS'
1434       include 'DIMENSIONS.ZSCOPT'
1435       include 'COMMON.CHAIN'
1436       include 'COMMON.DERIV'
1437       include 'COMMON.CALC'
1438       double precision dcosom1(3),dcosom2(3)
1439       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1440       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1441       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1442      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1443       do k=1,3
1444         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1445         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1446       enddo
1447       do k=1,3
1448         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1449       enddo
1450       do k=1,3
1451         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1452      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1453      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1454         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1455      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1456      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1457       enddo
1458 C
1459 C Calculate the components of the gradient in DC and X
1460 C
1461       do k=i,j-1
1462         do l=1,3
1463           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1464         enddo
1465       enddo
1466       return
1467       end
1468 c------------------------------------------------------------------------------
1469       subroutine vec_and_deriv
1470       implicit real*8 (a-h,o-z)
1471       include 'DIMENSIONS'
1472       include 'DIMENSIONS.ZSCOPT'
1473       include 'COMMON.IOUNITS'
1474       include 'COMMON.GEO'
1475       include 'COMMON.VAR'
1476       include 'COMMON.LOCAL'
1477       include 'COMMON.CHAIN'
1478       include 'COMMON.VECTORS'
1479       include 'COMMON.DERIV'
1480       include 'COMMON.INTERACT'
1481       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1482 C Compute the local reference systems. For reference system (i), the
1483 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1484 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1485       do i=1,nres-1
1486 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1487           if (i.eq.nres-1) then
1488 C Case of the last full residue
1489 C Compute the Z-axis
1490             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1491             costh=dcos(pi-theta(nres))
1492             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1493             do k=1,3
1494               uz(k,i)=fac*uz(k,i)
1495             enddo
1496             if (calc_grad) then
1497 C Compute the derivatives of uz
1498             uzder(1,1,1)= 0.0d0
1499             uzder(2,1,1)=-dc_norm(3,i-1)
1500             uzder(3,1,1)= dc_norm(2,i-1)
1501             uzder(1,2,1)= dc_norm(3,i-1)
1502             uzder(2,2,1)= 0.0d0
1503             uzder(3,2,1)=-dc_norm(1,i-1)
1504             uzder(1,3,1)=-dc_norm(2,i-1)
1505             uzder(2,3,1)= dc_norm(1,i-1)
1506             uzder(3,3,1)= 0.0d0
1507             uzder(1,1,2)= 0.0d0
1508             uzder(2,1,2)= dc_norm(3,i)
1509             uzder(3,1,2)=-dc_norm(2,i)
1510             uzder(1,2,2)=-dc_norm(3,i)
1511             uzder(2,2,2)= 0.0d0
1512             uzder(3,2,2)= dc_norm(1,i)
1513             uzder(1,3,2)= dc_norm(2,i)
1514             uzder(2,3,2)=-dc_norm(1,i)
1515             uzder(3,3,2)= 0.0d0
1516             endif
1517 C Compute the Y-axis
1518             facy=fac
1519             do k=1,3
1520               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1521             enddo
1522             if (calc_grad) then
1523 C Compute the derivatives of uy
1524             do j=1,3
1525               do k=1,3
1526                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1527      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1528                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1529               enddo
1530               uyder(j,j,1)=uyder(j,j,1)-costh
1531               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1532             enddo
1533             do j=1,2
1534               do k=1,3
1535                 do l=1,3
1536                   uygrad(l,k,j,i)=uyder(l,k,j)
1537                   uzgrad(l,k,j,i)=uzder(l,k,j)
1538                 enddo
1539               enddo
1540             enddo
1541             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1542             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1543             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1544             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1545             endif
1546           else
1547 C Other residues
1548 C Compute the Z-axis
1549             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1550             costh=dcos(pi-theta(i+2))
1551             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1552             do k=1,3
1553               uz(k,i)=fac*uz(k,i)
1554             enddo
1555             if (calc_grad) then
1556 C Compute the derivatives of uz
1557             uzder(1,1,1)= 0.0d0
1558             uzder(2,1,1)=-dc_norm(3,i+1)
1559             uzder(3,1,1)= dc_norm(2,i+1)
1560             uzder(1,2,1)= dc_norm(3,i+1)
1561             uzder(2,2,1)= 0.0d0
1562             uzder(3,2,1)=-dc_norm(1,i+1)
1563             uzder(1,3,1)=-dc_norm(2,i+1)
1564             uzder(2,3,1)= dc_norm(1,i+1)
1565             uzder(3,3,1)= 0.0d0
1566             uzder(1,1,2)= 0.0d0
1567             uzder(2,1,2)= dc_norm(3,i)
1568             uzder(3,1,2)=-dc_norm(2,i)
1569             uzder(1,2,2)=-dc_norm(3,i)
1570             uzder(2,2,2)= 0.0d0
1571             uzder(3,2,2)= dc_norm(1,i)
1572             uzder(1,3,2)= dc_norm(2,i)
1573             uzder(2,3,2)=-dc_norm(1,i)
1574             uzder(3,3,2)= 0.0d0
1575             endif
1576 C Compute the Y-axis
1577             facy=fac
1578             do k=1,3
1579               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1580             enddo
1581             if (calc_grad) then
1582 C Compute the derivatives of uy
1583             do j=1,3
1584               do k=1,3
1585                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1586      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1587                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1588               enddo
1589               uyder(j,j,1)=uyder(j,j,1)-costh
1590               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1591             enddo
1592             do j=1,2
1593               do k=1,3
1594                 do l=1,3
1595                   uygrad(l,k,j,i)=uyder(l,k,j)
1596                   uzgrad(l,k,j,i)=uzder(l,k,j)
1597                 enddo
1598               enddo
1599             enddo
1600             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1601             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1602             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1603             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1604           endif
1605           endif
1606       enddo
1607       if (calc_grad) then
1608       do i=1,nres-1
1609         vbld_inv_temp(1)=vbld_inv(i+1)
1610         if (i.lt.nres-1) then
1611           vbld_inv_temp(2)=vbld_inv(i+2)
1612         else
1613           vbld_inv_temp(2)=vbld_inv(i)
1614         endif
1615         do j=1,2
1616           do k=1,3
1617             do l=1,3
1618               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1619               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1620             enddo
1621           enddo
1622         enddo
1623       enddo
1624       endif
1625       return
1626       end
1627 C-----------------------------------------------------------------------------
1628       subroutine vec_and_deriv_test
1629       implicit real*8 (a-h,o-z)
1630       include 'DIMENSIONS'
1631       include 'DIMENSIONS.ZSCOPT'
1632       include 'COMMON.IOUNITS'
1633       include 'COMMON.GEO'
1634       include 'COMMON.VAR'
1635       include 'COMMON.LOCAL'
1636       include 'COMMON.CHAIN'
1637       include 'COMMON.VECTORS'
1638       dimension uyder(3,3,2),uzder(3,3,2)
1639 C Compute the local reference systems. For reference system (i), the
1640 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1641 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1642       do i=1,nres-1
1643           if (i.eq.nres-1) then
1644 C Case of the last full residue
1645 C Compute the Z-axis
1646             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1647             costh=dcos(pi-theta(nres))
1648             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1649 c            write (iout,*) 'fac',fac,
1650 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1651             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1652             do k=1,3
1653               uz(k,i)=fac*uz(k,i)
1654             enddo
1655 C Compute the derivatives of uz
1656             uzder(1,1,1)= 0.0d0
1657             uzder(2,1,1)=-dc_norm(3,i-1)
1658             uzder(3,1,1)= dc_norm(2,i-1)
1659             uzder(1,2,1)= dc_norm(3,i-1)
1660             uzder(2,2,1)= 0.0d0
1661             uzder(3,2,1)=-dc_norm(1,i-1)
1662             uzder(1,3,1)=-dc_norm(2,i-1)
1663             uzder(2,3,1)= dc_norm(1,i-1)
1664             uzder(3,3,1)= 0.0d0
1665             uzder(1,1,2)= 0.0d0
1666             uzder(2,1,2)= dc_norm(3,i)
1667             uzder(3,1,2)=-dc_norm(2,i)
1668             uzder(1,2,2)=-dc_norm(3,i)
1669             uzder(2,2,2)= 0.0d0
1670             uzder(3,2,2)= dc_norm(1,i)
1671             uzder(1,3,2)= dc_norm(2,i)
1672             uzder(2,3,2)=-dc_norm(1,i)
1673             uzder(3,3,2)= 0.0d0
1674 C Compute the Y-axis
1675             do k=1,3
1676               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1677             enddo
1678             facy=fac
1679             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1680      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1681      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1682             do k=1,3
1683 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1684               uy(k,i)=
1685 c     &        facy*(
1686      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1687      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1688 c     &        )
1689             enddo
1690 c            write (iout,*) 'facy',facy,
1691 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1692             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1693             do k=1,3
1694               uy(k,i)=facy*uy(k,i)
1695             enddo
1696 C Compute the derivatives of uy
1697             do j=1,3
1698               do k=1,3
1699                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1700      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1701                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1702               enddo
1703 c              uyder(j,j,1)=uyder(j,j,1)-costh
1704 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1705               uyder(j,j,1)=uyder(j,j,1)
1706      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1707               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1708      &          +uyder(j,j,2)
1709             enddo
1710             do j=1,2
1711               do k=1,3
1712                 do l=1,3
1713                   uygrad(l,k,j,i)=uyder(l,k,j)
1714                   uzgrad(l,k,j,i)=uzder(l,k,j)
1715                 enddo
1716               enddo
1717             enddo
1718             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1719             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1720             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1721             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1722           else
1723 C Other residues
1724 C Compute the Z-axis
1725             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1726             costh=dcos(pi-theta(i+2))
1727             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1728             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1729             do k=1,3
1730               uz(k,i)=fac*uz(k,i)
1731             enddo
1732 C Compute the derivatives of uz
1733             uzder(1,1,1)= 0.0d0
1734             uzder(2,1,1)=-dc_norm(3,i+1)
1735             uzder(3,1,1)= dc_norm(2,i+1)
1736             uzder(1,2,1)= dc_norm(3,i+1)
1737             uzder(2,2,1)= 0.0d0
1738             uzder(3,2,1)=-dc_norm(1,i+1)
1739             uzder(1,3,1)=-dc_norm(2,i+1)
1740             uzder(2,3,1)= dc_norm(1,i+1)
1741             uzder(3,3,1)= 0.0d0
1742             uzder(1,1,2)= 0.0d0
1743             uzder(2,1,2)= dc_norm(3,i)
1744             uzder(3,1,2)=-dc_norm(2,i)
1745             uzder(1,2,2)=-dc_norm(3,i)
1746             uzder(2,2,2)= 0.0d0
1747             uzder(3,2,2)= dc_norm(1,i)
1748             uzder(1,3,2)= dc_norm(2,i)
1749             uzder(2,3,2)=-dc_norm(1,i)
1750             uzder(3,3,2)= 0.0d0
1751 C Compute the Y-axis
1752             facy=fac
1753             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1754      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1755      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1756             do k=1,3
1757 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1758               uy(k,i)=
1759 c     &        facy*(
1760      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1761      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1762 c     &        )
1763             enddo
1764 c            write (iout,*) 'facy',facy,
1765 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1766             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1767             do k=1,3
1768               uy(k,i)=facy*uy(k,i)
1769             enddo
1770 C Compute the derivatives of uy
1771             do j=1,3
1772               do k=1,3
1773                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1774      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1775                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1776               enddo
1777 c              uyder(j,j,1)=uyder(j,j,1)-costh
1778 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1779               uyder(j,j,1)=uyder(j,j,1)
1780      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1781               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1782      &          +uyder(j,j,2)
1783             enddo
1784             do j=1,2
1785               do k=1,3
1786                 do l=1,3
1787                   uygrad(l,k,j,i)=uyder(l,k,j)
1788                   uzgrad(l,k,j,i)=uzder(l,k,j)
1789                 enddo
1790               enddo
1791             enddo
1792             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1793             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1794             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1795             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1796           endif
1797       enddo
1798       do i=1,nres-1
1799         do j=1,2
1800           do k=1,3
1801             do l=1,3
1802               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1803               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1804             enddo
1805           enddo
1806         enddo
1807       enddo
1808       return
1809       end
1810 C-----------------------------------------------------------------------------
1811       subroutine check_vecgrad
1812       implicit real*8 (a-h,o-z)
1813       include 'DIMENSIONS'
1814       include 'DIMENSIONS.ZSCOPT'
1815       include 'COMMON.IOUNITS'
1816       include 'COMMON.GEO'
1817       include 'COMMON.VAR'
1818       include 'COMMON.LOCAL'
1819       include 'COMMON.CHAIN'
1820       include 'COMMON.VECTORS'
1821       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1822       dimension uyt(3,maxres),uzt(3,maxres)
1823       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1824       double precision delta /1.0d-7/
1825       call vec_and_deriv
1826 cd      do i=1,nres
1827 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1828 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1829 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1830 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1831 cd     &     (dc_norm(if90,i),if90=1,3)
1832 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1833 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1834 cd          write(iout,'(a)')
1835 cd      enddo
1836       do i=1,nres
1837         do j=1,2
1838           do k=1,3
1839             do l=1,3
1840               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1841               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1842             enddo
1843           enddo
1844         enddo
1845       enddo
1846       call vec_and_deriv
1847       do i=1,nres
1848         do j=1,3
1849           uyt(j,i)=uy(j,i)
1850           uzt(j,i)=uz(j,i)
1851         enddo
1852       enddo
1853       do i=1,nres
1854 cd        write (iout,*) 'i=',i
1855         do k=1,3
1856           erij(k)=dc_norm(k,i)
1857         enddo
1858         do j=1,3
1859           do k=1,3
1860             dc_norm(k,i)=erij(k)
1861           enddo
1862           dc_norm(j,i)=dc_norm(j,i)+delta
1863 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1864 c          do k=1,3
1865 c            dc_norm(k,i)=dc_norm(k,i)/fac
1866 c          enddo
1867 c          write (iout,*) (dc_norm(k,i),k=1,3)
1868 c          write (iout,*) (erij(k),k=1,3)
1869           call vec_and_deriv
1870           do k=1,3
1871             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1872             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1873             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1874             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1875           enddo
1876 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1877 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1878 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1879         enddo
1880         do k=1,3
1881           dc_norm(k,i)=erij(k)
1882         enddo
1883 cd        do k=1,3
1884 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1885 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1886 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1887 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1888 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1889 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1890 cd          write (iout,'(a)')
1891 cd        enddo
1892       enddo
1893       return
1894       end
1895 C--------------------------------------------------------------------------
1896       subroutine set_matrices
1897       implicit real*8 (a-h,o-z)
1898       include 'DIMENSIONS'
1899       include 'DIMENSIONS.ZSCOPT'
1900       include 'COMMON.IOUNITS'
1901       include 'COMMON.GEO'
1902       include 'COMMON.VAR'
1903       include 'COMMON.LOCAL'
1904       include 'COMMON.CHAIN'
1905       include 'COMMON.DERIV'
1906       include 'COMMON.INTERACT'
1907       include 'COMMON.CONTACTS'
1908       include 'COMMON.TORSION'
1909       include 'COMMON.VECTORS'
1910       include 'COMMON.FFIELD'
1911       double precision auxvec(2),auxmat(2,2)
1912 C
1913 C Compute the virtual-bond-torsional-angle dependent quantities needed
1914 C to calculate the el-loc multibody terms of various order.
1915 C
1916       do i=3,nres+1
1917         if (i .lt. nres+1) then
1918           sin1=dsin(phi(i))
1919           cos1=dcos(phi(i))
1920           sintab(i-2)=sin1
1921           costab(i-2)=cos1
1922           obrot(1,i-2)=cos1
1923           obrot(2,i-2)=sin1
1924           sin2=dsin(2*phi(i))
1925           cos2=dcos(2*phi(i))
1926           sintab2(i-2)=sin2
1927           costab2(i-2)=cos2
1928           obrot2(1,i-2)=cos2
1929           obrot2(2,i-2)=sin2
1930           Ug(1,1,i-2)=-cos1
1931           Ug(1,2,i-2)=-sin1
1932           Ug(2,1,i-2)=-sin1
1933           Ug(2,2,i-2)= cos1
1934           Ug2(1,1,i-2)=-cos2
1935           Ug2(1,2,i-2)=-sin2
1936           Ug2(2,1,i-2)=-sin2
1937           Ug2(2,2,i-2)= cos2
1938         else
1939           costab(i-2)=1.0d0
1940           sintab(i-2)=0.0d0
1941           obrot(1,i-2)=1.0d0
1942           obrot(2,i-2)=0.0d0
1943           obrot2(1,i-2)=0.0d0
1944           obrot2(2,i-2)=0.0d0
1945           Ug(1,1,i-2)=1.0d0
1946           Ug(1,2,i-2)=0.0d0
1947           Ug(2,1,i-2)=0.0d0
1948           Ug(2,2,i-2)=1.0d0
1949           Ug2(1,1,i-2)=0.0d0
1950           Ug2(1,2,i-2)=0.0d0
1951           Ug2(2,1,i-2)=0.0d0
1952           Ug2(2,2,i-2)=0.0d0
1953         endif
1954         if (i .gt. 3 .and. i .lt. nres+1) then
1955           obrot_der(1,i-2)=-sin1
1956           obrot_der(2,i-2)= cos1
1957           Ugder(1,1,i-2)= sin1
1958           Ugder(1,2,i-2)=-cos1
1959           Ugder(2,1,i-2)=-cos1
1960           Ugder(2,2,i-2)=-sin1
1961           dwacos2=cos2+cos2
1962           dwasin2=sin2+sin2
1963           obrot2_der(1,i-2)=-dwasin2
1964           obrot2_der(2,i-2)= dwacos2
1965           Ug2der(1,1,i-2)= dwasin2
1966           Ug2der(1,2,i-2)=-dwacos2
1967           Ug2der(2,1,i-2)=-dwacos2
1968           Ug2der(2,2,i-2)=-dwasin2
1969         else
1970           obrot_der(1,i-2)=0.0d0
1971           obrot_der(2,i-2)=0.0d0
1972           Ugder(1,1,i-2)=0.0d0
1973           Ugder(1,2,i-2)=0.0d0
1974           Ugder(2,1,i-2)=0.0d0
1975           Ugder(2,2,i-2)=0.0d0
1976           obrot2_der(1,i-2)=0.0d0
1977           obrot2_der(2,i-2)=0.0d0
1978           Ug2der(1,1,i-2)=0.0d0
1979           Ug2der(1,2,i-2)=0.0d0
1980           Ug2der(2,1,i-2)=0.0d0
1981           Ug2der(2,2,i-2)=0.0d0
1982         endif
1983         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1984           if (itype(i-2).le.ntyp) then
1985             iti = itortyp(itype(i-2))
1986           else
1987             iti=ntortyp+1
1988           endif
1989         else
1990           iti=ntortyp+1
1991         endif
1992         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1993           if (itype(i-1).le.ntyp) then
1994             iti1 = itortyp(itype(i-1))
1995           else
1996             iti1=ntortyp+1
1997           endif
1998         else
1999           iti1=ntortyp+1
2000         endif
2001 cd        write (iout,*) '*******i',i,' iti1',iti
2002 cd        write (iout,*) 'b1',b1(:,iti)
2003 cd        write (iout,*) 'b2',b2(:,iti)
2004 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2005 c        print *,"itilde1 i iti iti1",i,iti,iti1
2006         if (i .gt. iatel_s+2) then
2007           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2008           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2009           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2010           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2011           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2012           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2013           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2014         else
2015           do k=1,2
2016             Ub2(k,i-2)=0.0d0
2017             Ctobr(k,i-2)=0.0d0
2018             Dtobr2(k,i-2)=0.0d0
2019             do l=1,2
2020               EUg(l,k,i-2)=0.0d0
2021               CUg(l,k,i-2)=0.0d0
2022               DUg(l,k,i-2)=0.0d0
2023               DtUg2(l,k,i-2)=0.0d0
2024             enddo
2025           enddo
2026         endif
2027 c        print *,"itilde2 i iti iti1",i,iti,iti1
2028         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2029         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2030         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2031         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2032         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2033         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2034         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2035 c        print *,"itilde3 i iti iti1",i,iti,iti1
2036         do k=1,2
2037           muder(k,i-2)=Ub2der(k,i-2)
2038         enddo
2039         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2040           if (itype(i-1).le.ntyp) then
2041             iti1 = itortyp(itype(i-1))
2042           else
2043             iti1=ntortyp+1
2044           endif
2045         else
2046           iti1=ntortyp+1
2047         endif
2048         do k=1,2
2049           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2050         enddo
2051 C        write (iout,*) 'mumu',i,b1(1,iti),Ub2(1,i-2)
2052
2053 C Vectors and matrices dependent on a single virtual-bond dihedral.
2054         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2055         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2056         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2057         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2058         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2059         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2060         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2061         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2062         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2063 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2064 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2065       enddo
2066 C Matrices dependent on two consecutive virtual-bond dihedrals.
2067 C The order of matrices is from left to right.
2068       do i=2,nres-1
2069         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2070         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2071         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2072         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2073         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2074         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2075         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2076         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2077       enddo
2078 cd      do i=1,nres
2079 cd        iti = itortyp(itype(i))
2080 cd        write (iout,*) i
2081 cd        do j=1,2
2082 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2083 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2084 cd        enddo
2085 cd      enddo
2086       return
2087       end
2088 C--------------------------------------------------------------------------
2089       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2090 C
2091 C This subroutine calculates the average interaction energy and its gradient
2092 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2093 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2094 C The potential depends both on the distance of peptide-group centers and on
2095 C the orientation of the CA-CA virtual bonds.
2096 C
2097       implicit real*8 (a-h,o-z)
2098       include 'DIMENSIONS'
2099       include 'DIMENSIONS.ZSCOPT'
2100       include 'COMMON.CONTROL'
2101       include 'COMMON.IOUNITS'
2102       include 'COMMON.GEO'
2103       include 'COMMON.VAR'
2104       include 'COMMON.LOCAL'
2105       include 'COMMON.CHAIN'
2106       include 'COMMON.DERIV'
2107       include 'COMMON.INTERACT'
2108       include 'COMMON.CONTACTS'
2109       include 'COMMON.TORSION'
2110       include 'COMMON.VECTORS'
2111       include 'COMMON.FFIELD'
2112       include 'COMMON.SHIELD'
2113       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2114      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2115       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2116      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2117       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2118 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2119       double precision scal_el /0.5d0/
2120 C 12/13/98
2121 C 13-go grudnia roku pamietnego...
2122       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2123      &                   0.0d0,1.0d0,0.0d0,
2124      &                   0.0d0,0.0d0,1.0d0/
2125 cd      write(iout,*) 'In EELEC'
2126 cd      do i=1,nloctyp
2127 cd        write(iout,*) 'Type',i
2128 cd        write(iout,*) 'B1',B1(:,i)
2129 cd        write(iout,*) 'B2',B2(:,i)
2130 cd        write(iout,*) 'CC',CC(:,:,i)
2131 cd        write(iout,*) 'DD',DD(:,:,i)
2132 cd        write(iout,*) 'EE',EE(:,:,i)
2133 cd      enddo
2134 cd      call check_vecgrad
2135 cd      stop
2136       if (icheckgrad.eq.1) then
2137         do i=1,nres-1
2138           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2139           do k=1,3
2140             dc_norm(k,i)=dc(k,i)*fac
2141           enddo
2142 c          write (iout,*) 'i',i,' fac',fac
2143         enddo
2144       endif
2145       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2146      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2147      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2148 cd      if (wel_loc.gt.0.0d0) then
2149         if (icheckgrad.eq.1) then
2150         call vec_and_deriv_test
2151         else
2152         call vec_and_deriv
2153         endif
2154         call set_matrices
2155       endif
2156 cd      do i=1,nres-1
2157 cd        write (iout,*) 'i=',i
2158 cd        do k=1,3
2159 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2160 cd        enddo
2161 cd        do k=1,3
2162 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2163 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2164 cd        enddo
2165 cd      enddo
2166       num_conti_hb=0
2167       ees=0.0D0
2168       evdw1=0.0D0
2169       eel_loc=0.0d0
2170       eello_turn3=0.0d0
2171       eello_turn4=0.0d0
2172       ind=0
2173       do i=1,nres
2174         num_cont_hb(i)=0
2175       enddo
2176 C      print '(a)','Enter EELEC'
2177 C      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2178       do i=1,nres
2179         gel_loc_loc(i)=0.0d0
2180         gcorr_loc(i)=0.0d0
2181       enddo
2182       do i=iatel_s,iatel_e
2183 C          if (i.eq.1) then
2184            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2185 C     &  .or. itype(i+2).eq.ntyp1) cycle
2186 C          else
2187 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2188 C     &  .or. itype(i+2).eq.ntyp1
2189 C     &  .or. itype(i-1).eq.ntyp1
2190      &) cycle
2191 C         endif
2192         if (itel(i).eq.0) goto 1215
2193         dxi=dc(1,i)
2194         dyi=dc(2,i)
2195         dzi=dc(3,i)
2196         dx_normi=dc_norm(1,i)
2197         dy_normi=dc_norm(2,i)
2198         dz_normi=dc_norm(3,i)
2199         xmedi=c(1,i)+0.5d0*dxi
2200         ymedi=c(2,i)+0.5d0*dyi
2201         zmedi=c(3,i)+0.5d0*dzi
2202           xmedi=mod(xmedi,boxxsize)
2203           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2204           ymedi=mod(ymedi,boxysize)
2205           if (ymedi.lt.0) ymedi=ymedi+boxysize
2206           zmedi=mod(zmedi,boxzsize)
2207           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2208           zmedi2=mod(zmedi,boxzsize)
2209           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
2210        if ((zmedi2.gt.bordlipbot)
2211      &.and.(zmedi2.lt.bordliptop)) then
2212 C the energy transfer exist
2213         if (zmedi2.lt.buflipbot) then
2214 C what fraction I am in
2215          fracinbuf=1.0d0-
2216      &        ((zmedi2-bordlipbot)/lipbufthick)
2217 C lipbufthick is thickenes of lipid buffore
2218          sslipi=sscalelip(fracinbuf)
2219          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2220         elseif (zmedi2.gt.bufliptop) then
2221          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
2222          sslipi=sscalelip(fracinbuf)
2223          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2224         else
2225          sslipi=1.0d0
2226          ssgradlipi=0.0d0
2227         endif
2228        else
2229          sslipi=0.0d0
2230          ssgradlipi=0.0d0
2231        endif
2232
2233         num_conti=0
2234 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2235         do j=ielstart(i),ielend(i)
2236           if (j.lt.1) cycle
2237 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2238 C     & .or.itype(j+2).eq.ntyp1
2239 C     &) cycle
2240 C          else
2241           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2242 C     & .or.itype(j+2).eq.ntyp1
2243 C     & .or.itype(j-1).eq.ntyp1
2244      &) cycle
2245 C         endif
2246 C
2247 C) cycle
2248           if (itel(j).eq.0) goto 1216
2249           ind=ind+1
2250           iteli=itel(i)
2251           itelj=itel(j)
2252           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2253           aaa=app(iteli,itelj)
2254           bbb=bpp(iteli,itelj)
2255 C Diagnostics only!!!
2256 c         aaa=0.0D0
2257 c         bbb=0.0D0
2258 c         ael6i=0.0D0
2259 c         ael3i=0.0D0
2260 C End diagnostics
2261           ael6i=ael6(iteli,itelj)
2262           ael3i=ael3(iteli,itelj)
2263           dxj=dc(1,j)
2264           dyj=dc(2,j)
2265           dzj=dc(3,j)
2266           dx_normj=dc_norm(1,j)
2267           dy_normj=dc_norm(2,j)
2268           dz_normj=dc_norm(3,j)
2269           xj=c(1,j)+0.5D0*dxj
2270           yj=c(2,j)+0.5D0*dyj
2271           zj=c(3,j)+0.5D0*dzj
2272          xj=mod(xj,boxxsize)
2273           if (xj.lt.0) xj=xj+boxxsize
2274           yj=mod(yj,boxysize)
2275           if (yj.lt.0) yj=yj+boxysize
2276           zj=mod(zj,boxzsize)
2277           if (zj.lt.0) zj=zj+boxzsize
2278        if ((zj.gt.bordlipbot)
2279      &.and.(zj.lt.bordliptop)) then
2280 C the energy transfer exist
2281         if (zj.lt.buflipbot) then
2282 C what fraction I am in
2283          fracinbuf=1.0d0-
2284      &        ((zj-bordlipbot)/lipbufthick)
2285 C lipbufthick is thickenes of lipid buffore
2286          sslipj=sscalelip(fracinbuf)
2287          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2288         elseif (zj.gt.bufliptop) then
2289          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2290          sslipj=sscalelip(fracinbuf)
2291          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2292         else
2293          sslipj=1.0d0
2294          ssgradlipj=0.0
2295         endif
2296        else
2297          sslipj=0.0d0
2298          ssgradlipj=0.0
2299        endif
2300       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2301       xj_safe=xj
2302       yj_safe=yj
2303       zj_safe=zj
2304       isubchap=0
2305       do xshift=-1,1
2306       do yshift=-1,1
2307       do zshift=-1,1
2308           xj=xj_safe+xshift*boxxsize
2309           yj=yj_safe+yshift*boxysize
2310           zj=zj_safe+zshift*boxzsize
2311           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2312           if(dist_temp.lt.dist_init) then
2313             dist_init=dist_temp
2314             xj_temp=xj
2315             yj_temp=yj
2316             zj_temp=zj
2317             isubchap=1
2318           endif
2319        enddo
2320        enddo
2321        enddo
2322        if (isubchap.eq.1) then
2323           xj=xj_temp-xmedi
2324           yj=yj_temp-ymedi
2325           zj=zj_temp-zmedi
2326        else
2327           xj=xj_safe-xmedi
2328           yj=yj_safe-ymedi
2329           zj=zj_safe-zmedi
2330        endif
2331           rij=xj*xj+yj*yj+zj*zj
2332             sss=sscale(sqrt(rij))
2333             sssgrad=sscagrad(sqrt(rij))
2334           rrmij=1.0D0/rij
2335           rij=dsqrt(rij)
2336           rmij=1.0D0/rij
2337           r3ij=rrmij*rmij
2338           r6ij=r3ij*r3ij
2339           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2340           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2341           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2342           fac=cosa-3.0D0*cosb*cosg
2343           ev1=aaa*r6ij*r6ij
2344 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2345           if (j.eq.i+2) ev1=scal_el*ev1
2346           ev2=bbb*r6ij
2347           fac3=ael6i*r6ij
2348           fac4=ael3i*r3ij
2349           evdwij=ev1+ev2
2350           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2351           el2=fac4*fac
2352           eesij=el1+el2
2353 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2354 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2355           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2356           if (shield_mode.gt.0) then
2357 C#define DEBUG
2358 #ifdef DEBUG
2359           write(iout,*) "ees_compon",i,j,el1,el2,
2360      &    fac_shield(i),fac_shield(j)
2361 #endif
2362 C#undef DEBUG
2363 C          fac_shield(i)=0.4
2364 C          fac_shield(j)=0.6
2365           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2366           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2367           eesij=(el1+el2)
2368           ees=ees+eesij
2369           else
2370           fac_shield(i)=1.0
2371           fac_shield(j)=1.0
2372           eesij=(el1+el2)
2373           ees=ees+eesij
2374           endif
2375           evdw1=evdw1+evdwij*sss
2376 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2377 c     &'evdw1',i,j,evdwij
2378 c     &,iteli,itelj,aaa,evdw1
2379
2380 C              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2381 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2382 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2383 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2384 c     &      xmedi,ymedi,zmedi,xj,yj,zj
2385 C
2386 C Calculate contributions to the Cartesian gradient.
2387 C
2388 #ifdef SPLITELE
2389           facvdw=-6*rrmij*(ev1+evdwij)*sss
2390           facel=-3*rrmij*(el1+eesij)
2391           fac1=fac
2392           erij(1)=xj*rmij
2393           erij(2)=yj*rmij
2394           erij(3)=zj*rmij
2395           if (calc_grad) then
2396 *
2397 * Radial derivatives. First process both termini of the fragment (i,j)
2398 *
2399           ggg(1)=facel*xj
2400           ggg(2)=facel*yj
2401           ggg(3)=facel*zj
2402           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2403      &  (shield_mode.gt.0)) then
2404 C          print *,i,j
2405           do ilist=1,ishield_list(i)
2406            iresshield=shield_list(ilist,i)
2407            do k=1,3
2408            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2409      &      *2.0
2410            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2411      &              rlocshield
2412      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2413             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2414 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2415 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2416 C             if (iresshield.gt.i) then
2417 C               do ishi=i+1,iresshield-1
2418 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2419 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2420 C
2421 C              enddo
2422 C             else
2423 C               do ishi=iresshield,i
2424 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2425 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2426 C
2427 C               enddo
2428 C              endif
2429            enddo
2430           enddo
2431           do ilist=1,ishield_list(j)
2432            iresshield=shield_list(ilist,j)
2433            do k=1,3
2434            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2435      &     *2.0
2436            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2437      &              rlocshield
2438      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2439            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2440            enddo
2441           enddo
2442
2443           do k=1,3
2444             gshieldc(k,i)=gshieldc(k,i)+
2445      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2446             gshieldc(k,j)=gshieldc(k,j)+
2447      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2448             gshieldc(k,i-1)=gshieldc(k,i-1)+
2449      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2450             gshieldc(k,j-1)=gshieldc(k,j-1)+
2451      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2452
2453            enddo
2454            endif
2455
2456           do k=1,3
2457             ghalf=0.5D0*ggg(k)
2458             gelc(k,i)=gelc(k,i)+ghalf
2459             gelc(k,j)=gelc(k,j)+ghalf
2460           enddo
2461 *
2462 * Loop over residues i+1 thru j-1.
2463 *
2464           do k=i+1,j-1
2465             do l=1,3
2466               gelc(l,k)=gelc(l,k)+ggg(l)
2467             enddo
2468           enddo
2469 C          ggg(1)=facvdw*xj
2470 C          ggg(2)=facvdw*yj
2471 C          ggg(3)=facvdw*zj
2472           if (sss.gt.0.0) then
2473           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2474           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2475           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2476           else
2477           ggg(1)=0.0
2478           ggg(2)=0.0
2479           ggg(3)=0.0
2480           endif
2481           do k=1,3
2482             ghalf=0.5D0*ggg(k)
2483             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2484             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2485           enddo
2486 *
2487 * Loop over residues i+1 thru j-1.
2488 *
2489           do k=i+1,j-1
2490             do l=1,3
2491               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2492             enddo
2493           enddo
2494 #else
2495           facvdw=(ev1+evdwij)*sss
2496           facel=el1+eesij
2497           fac1=fac
2498           fac=-3*rrmij*(facvdw+facvdw+facel)
2499           erij(1)=xj*rmij
2500           erij(2)=yj*rmij
2501           erij(3)=zj*rmij
2502           if (calc_grad) then
2503 *
2504 * Radial derivatives. First process both termini of the fragment (i,j)
2505 *
2506           ggg(1)=fac*xj
2507           ggg(2)=fac*yj
2508           ggg(3)=fac*zj
2509           do k=1,3
2510             ghalf=0.5D0*ggg(k)
2511             gelc(k,i)=gelc(k,i)+ghalf
2512             gelc(k,j)=gelc(k,j)+ghalf
2513           enddo
2514 *
2515 * Loop over residues i+1 thru j-1.
2516 *
2517           do k=i+1,j-1
2518             do l=1,3
2519               gelc(l,k)=gelc(l,k)+ggg(l)
2520             enddo
2521           enddo
2522 #endif
2523 *
2524 * Angular part
2525 *
2526           ecosa=2.0D0*fac3*fac1+fac4
2527           fac4=-3.0D0*fac4
2528           fac3=-6.0D0*fac3
2529           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2530           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2531           do k=1,3
2532             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2533             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2534           enddo
2535 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2536 cd   &          (dcosg(k),k=1,3)
2537           do k=1,3
2538             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2539      &      *fac_shield(i)**2*fac_shield(j)**2
2540           enddo
2541           do k=1,3
2542             ghalf=0.5D0*ggg(k)
2543             gelc(k,i)=gelc(k,i)+ghalf
2544      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2545      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2546      &           *fac_shield(i)**2*fac_shield(j)**2
2547
2548             gelc(k,j)=gelc(k,j)+ghalf
2549      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2550      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2551      &           *fac_shield(i)**2*fac_shield(j)**2
2552           enddo
2553           do k=i+1,j-1
2554             do l=1,3
2555               gelc(l,k)=gelc(l,k)+ggg(l)
2556             enddo
2557           enddo
2558           endif
2559
2560           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2561      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2562      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2563 C
2564 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2565 C   energy of a peptide unit is assumed in the form of a second-order
2566 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2567 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2568 C   are computed for EVERY pair of non-contiguous peptide groups.
2569 C
2570           if (j.lt.nres-1) then
2571             j1=j+1
2572             j2=j-1
2573           else
2574             j1=j-1
2575             j2=j-2
2576           endif
2577           kkk=0
2578           do k=1,2
2579             do l=1,2
2580               kkk=kkk+1
2581               muij(kkk)=mu(k,i)*mu(l,j)
2582             enddo
2583           enddo
2584 cd         write (iout,*) 'EELEC: i',i,' j',j
2585 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2586 cd          write(iout,*) 'muij',muij
2587           ury=scalar(uy(1,i),erij)
2588           urz=scalar(uz(1,i),erij)
2589           vry=scalar(uy(1,j),erij)
2590           vrz=scalar(uz(1,j),erij)
2591           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2592           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2593           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2594           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2595 C For diagnostics only
2596 cd          a22=1.0d0
2597 cd          a23=1.0d0
2598 cd          a32=1.0d0
2599 cd          a33=1.0d0
2600           fac=dsqrt(-ael6i)*r3ij
2601 cd          write (2,*) 'fac=',fac
2602 C For diagnostics only
2603 cd          fac=1.0d0
2604           a22=a22*fac
2605           a23=a23*fac
2606           a32=a32*fac
2607           a33=a33*fac
2608 cd          write (iout,'(4i5,4f10.5)')
2609 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2610 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2611 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2612 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2613 cd          write (iout,'(4f10.5)')
2614 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2615 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2616 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2617 cd           write (iout,'(2i3,9f10.5/)') i,j,
2618 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2619           if (calc_grad) then
2620 C Derivatives of the elements of A in virtual-bond vectors
2621           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2622 cd          do k=1,3
2623 cd            do l=1,3
2624 cd              erder(k,l)=0.0d0
2625 cd            enddo
2626 cd          enddo
2627           do k=1,3
2628             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2629             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2630             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2631             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2632             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2633             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2634             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2635             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2636             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2637             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2638             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2639             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2640           enddo
2641 cd          do k=1,3
2642 cd            do l=1,3
2643 cd              uryg(k,l)=0.0d0
2644 cd              urzg(k,l)=0.0d0
2645 cd              vryg(k,l)=0.0d0
2646 cd              vrzg(k,l)=0.0d0
2647 cd            enddo
2648 cd          enddo
2649 C Compute radial contributions to the gradient
2650           facr=-3.0d0*rrmij
2651           a22der=a22*facr
2652           a23der=a23*facr
2653           a32der=a32*facr
2654           a33der=a33*facr
2655 cd          a22der=0.0d0
2656 cd          a23der=0.0d0
2657 cd          a32der=0.0d0
2658 cd          a33der=0.0d0
2659           agg(1,1)=a22der*xj
2660           agg(2,1)=a22der*yj
2661           agg(3,1)=a22der*zj
2662           agg(1,2)=a23der*xj
2663           agg(2,2)=a23der*yj
2664           agg(3,2)=a23der*zj
2665           agg(1,3)=a32der*xj
2666           agg(2,3)=a32der*yj
2667           agg(3,3)=a32der*zj
2668           agg(1,4)=a33der*xj
2669           agg(2,4)=a33der*yj
2670           agg(3,4)=a33der*zj
2671 C Add the contributions coming from er
2672           fac3=-3.0d0*fac
2673           do k=1,3
2674             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2675             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2676             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2677             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2678           enddo
2679           do k=1,3
2680 C Derivatives in DC(i)
2681             ghalf1=0.5d0*agg(k,1)
2682             ghalf2=0.5d0*agg(k,2)
2683             ghalf3=0.5d0*agg(k,3)
2684             ghalf4=0.5d0*agg(k,4)
2685             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2686      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2687             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2688      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2689             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2690      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2691             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2692      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2693 C Derivatives in DC(i+1)
2694             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2695      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2696             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2697      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2698             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2699      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2700             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2701      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2702 C Derivatives in DC(j)
2703             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2704      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2705             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2706      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2707             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2708      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2709             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2710      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2711 C Derivatives in DC(j+1) or DC(nres-1)
2712             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2713      &      -3.0d0*vryg(k,3)*ury)
2714             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2715      &      -3.0d0*vrzg(k,3)*ury)
2716             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2717      &      -3.0d0*vryg(k,3)*urz)
2718             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2719      &      -3.0d0*vrzg(k,3)*urz)
2720 cd            aggi(k,1)=ghalf1
2721 cd            aggi(k,2)=ghalf2
2722 cd            aggi(k,3)=ghalf3
2723 cd            aggi(k,4)=ghalf4
2724 C Derivatives in DC(i+1)
2725 cd            aggi1(k,1)=agg(k,1)
2726 cd            aggi1(k,2)=agg(k,2)
2727 cd            aggi1(k,3)=agg(k,3)
2728 cd            aggi1(k,4)=agg(k,4)
2729 C Derivatives in DC(j)
2730 cd            aggj(k,1)=ghalf1
2731 cd            aggj(k,2)=ghalf2
2732 cd            aggj(k,3)=ghalf3
2733 cd            aggj(k,4)=ghalf4
2734 C Derivatives in DC(j+1)
2735 cd            aggj1(k,1)=0.0d0
2736 cd            aggj1(k,2)=0.0d0
2737 cd            aggj1(k,3)=0.0d0
2738 cd            aggj1(k,4)=0.0d0
2739             if (j.eq.nres-1 .and. i.lt.j-2) then
2740               do l=1,4
2741                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2742 cd                aggj1(k,l)=agg(k,l)
2743               enddo
2744             endif
2745           enddo
2746           endif
2747 c          goto 11111
2748 C Check the loc-el terms by numerical integration
2749           acipa(1,1)=a22
2750           acipa(1,2)=a23
2751           acipa(2,1)=a32
2752           acipa(2,2)=a33
2753           a22=-a22
2754           a23=-a23
2755           do l=1,2
2756             do k=1,3
2757               agg(k,l)=-agg(k,l)
2758               aggi(k,l)=-aggi(k,l)
2759               aggi1(k,l)=-aggi1(k,l)
2760               aggj(k,l)=-aggj(k,l)
2761               aggj1(k,l)=-aggj1(k,l)
2762             enddo
2763           enddo
2764           if (j.lt.nres-1) then
2765             a22=-a22
2766             a32=-a32
2767             do l=1,3,2
2768               do k=1,3
2769                 agg(k,l)=-agg(k,l)
2770                 aggi(k,l)=-aggi(k,l)
2771                 aggi1(k,l)=-aggi1(k,l)
2772                 aggj(k,l)=-aggj(k,l)
2773                 aggj1(k,l)=-aggj1(k,l)
2774               enddo
2775             enddo
2776           else
2777             a22=-a22
2778             a23=-a23
2779             a32=-a32
2780             a33=-a33
2781             do l=1,4
2782               do k=1,3
2783                 agg(k,l)=-agg(k,l)
2784                 aggi(k,l)=-aggi(k,l)
2785                 aggi1(k,l)=-aggi1(k,l)
2786                 aggj(k,l)=-aggj(k,l)
2787                 aggj1(k,l)=-aggj1(k,l)
2788               enddo
2789             enddo
2790           endif
2791           ENDIF ! WCORR
2792 11111     continue
2793           IF (wel_loc.gt.0.0d0) THEN
2794 C Contribution to the local-electrostatic energy coming from the i-j pair
2795           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2796      &     +a33*muij(4)
2797           if (shield_mode.eq.0) then
2798            fac_shield(i)=1.0
2799            fac_shield(j)=1.0
2800 C          else
2801 C           fac_shield(i)=0.4
2802 C           fac_shield(j)=0.6
2803           endif
2804           eel_loc_ij=eel_loc_ij
2805      &    *fac_shield(i)*fac_shield(j)
2806      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2807 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2808 C          write (iout,'(a6,2i5,0pf7.3)')
2809 C     &            'eelloc',i,j,eel_loc_ij
2810 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2811 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2812 C          eel_loc=eel_loc+eel_loc_ij
2813           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2814      &  (shield_mode.gt.0)) then
2815 C          print *,i,j
2816
2817           do ilist=1,ishield_list(i)
2818            iresshield=shield_list(ilist,i)
2819            do k=1,3
2820            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2821      &                                          /fac_shield(i)
2822 C     &      *2.0
2823            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2824      &              rlocshield
2825      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2826             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2827      &      +rlocshield
2828            enddo
2829           enddo
2830           do ilist=1,ishield_list(j)
2831            iresshield=shield_list(ilist,j)
2832            do k=1,3
2833            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2834      &                                       /fac_shield(j)
2835 C     &     *2.0
2836            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2837      &              rlocshield
2838      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2839            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2840      &             +rlocshield
2841
2842            enddo
2843           enddo
2844           do k=1,3
2845             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2846      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2847             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2848      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2849             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2850      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2851             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2852      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2853            enddo
2854            endif
2855           eel_loc=eel_loc+eel_loc_ij
2856
2857 C Partial derivatives in virtual-bond dihedral angles gamma
2858           if (calc_grad) then
2859           if (i.gt.1)
2860      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2861      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2862      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
2863      &    *fac_shield(i)*fac_shield(j)
2864      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2865
2866           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2867      &            (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2868      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
2869      &    *fac_shield(i)*fac_shield(j)
2870      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2871
2872 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2873 cd          write(iout,*) 'agg  ',agg
2874 cd          write(iout,*) 'aggi ',aggi
2875 cd          write(iout,*) 'aggi1',aggi1
2876 cd          write(iout,*) 'aggj ',aggj
2877 cd          write(iout,*) 'aggj1',aggj1
2878
2879 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2880           do l=1,3
2881             ggg(l)=(agg(l,1)*muij(1)+
2882      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
2883      &    *fac_shield(i)*fac_shield(j)
2884      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2885
2886           enddo
2887           do k=i+2,j2
2888             do l=1,3
2889               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2890             enddo
2891           enddo
2892 C Remaining derivatives of eello
2893           do l=1,3
2894             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
2895      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
2896      &    *fac_shield(i)*fac_shield(j)
2897      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2898
2899             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
2900      &         aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
2901      &    *fac_shield(i)*fac_shield(j)
2902      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2903
2904             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
2905      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
2906      &    *fac_shield(i)*fac_shield(j)
2907      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2908
2909             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
2910      &         aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
2911      &    *fac_shield(i)*fac_shield(j)
2912      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2913
2914           enddo
2915           endif
2916           ENDIF
2917           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2918 C Contributions from turns
2919             a_temp(1,1)=a22
2920             a_temp(1,2)=a23
2921             a_temp(2,1)=a32
2922             a_temp(2,2)=a33
2923             call eturn34(i,j,eello_turn3,eello_turn4)
2924           endif
2925 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2926           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2927 C
2928 C Calculate the contact function. The ith column of the array JCONT will
2929 C contain the numbers of atoms that make contacts with the atom I (of numbers
2930 C greater than I). The arrays FACONT and GACONT will contain the values of
2931 C the contact function and its derivative.
2932 c           r0ij=1.02D0*rpp(iteli,itelj)
2933 c           r0ij=1.11D0*rpp(iteli,itelj)
2934             r0ij=2.20D0*rpp(iteli,itelj)
2935 c           r0ij=1.55D0*rpp(iteli,itelj)
2936             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2937             if (fcont.gt.0.0D0) then
2938               num_conti=num_conti+1
2939               if (num_conti.gt.maxconts) then
2940                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2941      &                         ' will skip next contacts for this conf.'
2942               else
2943                 jcont_hb(num_conti,i)=j
2944                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2945      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2946 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2947 C  terms.
2948                 d_cont(num_conti,i)=rij
2949 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2950 C     --- Electrostatic-interaction matrix ---
2951                 a_chuj(1,1,num_conti,i)=a22
2952                 a_chuj(1,2,num_conti,i)=a23
2953                 a_chuj(2,1,num_conti,i)=a32
2954                 a_chuj(2,2,num_conti,i)=a33
2955 C     --- Gradient of rij
2956                 do kkk=1,3
2957                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2958                 enddo
2959 c             if (i.eq.1) then
2960 c                a_chuj(1,1,num_conti,i)=-0.61d0
2961 c                a_chuj(1,2,num_conti,i)= 0.4d0
2962 c                a_chuj(2,1,num_conti,i)= 0.65d0
2963 c                a_chuj(2,2,num_conti,i)= 0.50d0
2964 c             else if (i.eq.2) then
2965 c                a_chuj(1,1,num_conti,i)= 0.0d0
2966 c                a_chuj(1,2,num_conti,i)= 0.0d0
2967 c                a_chuj(2,1,num_conti,i)= 0.0d0
2968 c                a_chuj(2,2,num_conti,i)= 0.0d0
2969 c             endif
2970 C     --- and its gradients
2971 cd                write (iout,*) 'i',i,' j',j
2972 cd                do kkk=1,3
2973 cd                write (iout,*) 'iii 1 kkk',kkk
2974 cd                write (iout,*) agg(kkk,:)
2975 cd                enddo
2976 cd                do kkk=1,3
2977 cd                write (iout,*) 'iii 2 kkk',kkk
2978 cd                write (iout,*) aggi(kkk,:)
2979 cd                enddo
2980 cd                do kkk=1,3
2981 cd                write (iout,*) 'iii 3 kkk',kkk
2982 cd                write (iout,*) aggi1(kkk,:)
2983 cd                enddo
2984 cd                do kkk=1,3
2985 cd                write (iout,*) 'iii 4 kkk',kkk
2986 cd                write (iout,*) aggj(kkk,:)
2987 cd                enddo
2988 cd                do kkk=1,3
2989 cd                write (iout,*) 'iii 5 kkk',kkk
2990 cd                write (iout,*) aggj1(kkk,:)
2991 cd                enddo
2992                 kkll=0
2993                 do k=1,2
2994                   do l=1,2
2995                     kkll=kkll+1
2996                     do m=1,3
2997                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2998                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2999                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3000                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3001                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3002 c                      do mm=1,5
3003 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
3004 c                      enddo
3005                     enddo
3006                   enddo
3007                 enddo
3008                 ENDIF
3009                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3010 C Calculate contact energies
3011                 cosa4=4.0D0*cosa
3012                 wij=cosa-3.0D0*cosb*cosg
3013                 cosbg1=cosb+cosg
3014                 cosbg2=cosb-cosg
3015 c               fac3=dsqrt(-ael6i)/r0ij**3
3016                 fac3=dsqrt(-ael6i)*r3ij
3017                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3018                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3019 c               ees0mij=0.0D0
3020                 if (shield_mode.eq.0) then
3021                 fac_shield(i)=1.0d0
3022                 fac_shield(j)=1.0d0
3023                 else
3024                 ees0plist(num_conti,i)=j
3025 C                fac_shield(i)=0.4d0
3026 C                fac_shield(j)=0.6d0
3027                 endif
3028                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3029      &          *fac_shield(i)*fac_shield(j)
3030
3031                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3032      &          *fac_shield(i)*fac_shield(j)
3033
3034 C Diagnostics. Comment out or remove after debugging!
3035 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3036 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3037 c               ees0m(num_conti,i)=0.0D0
3038 C End diagnostics.
3039 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3040 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3041                 facont_hb(num_conti,i)=fcont
3042                 if (calc_grad) then
3043 C Angular derivatives of the contact function
3044                 ees0pij1=fac3/ees0pij
3045                 ees0mij1=fac3/ees0mij
3046                 fac3p=-3.0D0*fac3*rrmij
3047                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3048                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3049 c               ees0mij1=0.0D0
3050                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3051                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3052                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3053                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3054                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3055                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3056                 ecosap=ecosa1+ecosa2
3057                 ecosbp=ecosb1+ecosb2
3058                 ecosgp=ecosg1+ecosg2
3059                 ecosam=ecosa1-ecosa2
3060                 ecosbm=ecosb1-ecosb2
3061                 ecosgm=ecosg1-ecosg2
3062 C Diagnostics
3063 c               ecosap=ecosa1
3064 c               ecosbp=ecosb1
3065 c               ecosgp=ecosg1
3066 c               ecosam=0.0D0
3067 c               ecosbm=0.0D0
3068 c               ecosgm=0.0D0
3069 C End diagnostics
3070                 fprimcont=fprimcont/rij
3071 cd              facont_hb(num_conti,i)=1.0D0
3072 C Following line is for diagnostics.
3073 cd              fprimcont=0.0D0
3074                 do k=1,3
3075                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3076                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3077                 enddo
3078                 do k=1,3
3079                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3080                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3081                 enddo
3082                 gggp(1)=gggp(1)+ees0pijp*xj
3083                 gggp(2)=gggp(2)+ees0pijp*yj
3084                 gggp(3)=gggp(3)+ees0pijp*zj
3085                 gggm(1)=gggm(1)+ees0mijp*xj
3086                 gggm(2)=gggm(2)+ees0mijp*yj
3087                 gggm(3)=gggm(3)+ees0mijp*zj
3088 C Derivatives due to the contact function
3089                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3090                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3091                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3092                 do k=1,3
3093                   ghalfp=0.5D0*gggp(k)
3094                   ghalfm=0.5D0*gggm(k)
3095                   gacontp_hb1(k,num_conti,i)=ghalfp
3096      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3097      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3098      &          *fac_shield(i)*fac_shield(j)
3099
3100                   gacontp_hb2(k,num_conti,i)=ghalfp
3101      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3102      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3103      &          *fac_shield(i)*fac_shield(j)
3104
3105                   gacontp_hb3(k,num_conti,i)=gggp(k)
3106      &          *fac_shield(i)*fac_shield(j)
3107
3108                   gacontm_hb1(k,num_conti,i)=ghalfm
3109      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3110      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3111      &          *fac_shield(i)*fac_shield(j)
3112
3113                   gacontm_hb2(k,num_conti,i)=ghalfm
3114      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3115      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3116      &          *fac_shield(i)*fac_shield(j)
3117
3118                   gacontm_hb3(k,num_conti,i)=gggm(k)
3119      &          *fac_shield(i)*fac_shield(j)
3120
3121                 enddo
3122                 endif
3123 C Diagnostics. Comment out or remove after debugging!
3124 cdiag           do k=1,3
3125 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3126 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3127 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3128 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3129 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3130 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3131 cdiag           enddo
3132               ENDIF ! wcorr
3133               endif  ! num_conti.le.maxconts
3134             endif  ! fcont.gt.0
3135           endif    ! j.gt.i+1
3136  1216     continue
3137         enddo ! j
3138         num_cont_hb(i)=num_conti
3139  1215   continue
3140       enddo   ! i
3141 cd      do i=1,nres
3142 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3143 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3144 cd      enddo
3145 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3146 ccc      eel_loc=eel_loc+eello_turn3
3147       return
3148       end
3149 C-----------------------------------------------------------------------------
3150       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3151 C Third- and fourth-order contributions from turns
3152       implicit real*8 (a-h,o-z)
3153       include 'DIMENSIONS'
3154       include 'DIMENSIONS.ZSCOPT'
3155       include 'COMMON.IOUNITS'
3156       include 'COMMON.GEO'
3157       include 'COMMON.VAR'
3158       include 'COMMON.LOCAL'
3159       include 'COMMON.CHAIN'
3160       include 'COMMON.DERIV'
3161       include 'COMMON.INTERACT'
3162       include 'COMMON.CONTACTS'
3163       include 'COMMON.TORSION'
3164       include 'COMMON.VECTORS'
3165       include 'COMMON.FFIELD'
3166       include 'COMMON.SHIELD'
3167       include 'COMMON.CONTROL'
3168       dimension ggg(3)
3169       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3170      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3171      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3172       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3173      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3174       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3175           zj=(c(3,j)+c(3,j+1))/2.0d0
3176 C          xj=mod(xj,boxxsize)
3177 C          if (xj.lt.0) xj=xj+boxxsize
3178 C          yj=mod(yj,boxysize)
3179 C          if (yj.lt.0) yj=yj+boxysize
3180           zj=mod(zj,boxzsize)
3181           if (zj.lt.0) zj=zj+boxzsize
3182 C          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3183        if ((zj.gt.bordlipbot)
3184      &.and.(zj.lt.bordliptop)) then
3185 C the energy transfer exist
3186         if (zj.lt.buflipbot) then
3187 C what fraction I am in
3188          fracinbuf=1.0d0-
3189      &        ((zj-bordlipbot)/lipbufthick)
3190 C lipbufthick is thickenes of lipid buffore
3191          sslipj=sscalelip(fracinbuf)
3192          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3193         elseif (zj.gt.bufliptop) then
3194          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3195          sslipj=sscalelip(fracinbuf)
3196          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3197         else
3198          sslipj=1.0d0
3199          ssgradlipj=0.0
3200         endif
3201        else
3202          sslipj=0.0d0
3203          ssgradlipj=0.0
3204        endif
3205
3206       if (j.eq.i+2) then
3207       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3208 C changes suggested by Ana to avoid out of bounds
3209 C     & .or.((i+5).gt.nres)
3210 C     & .or.((i-1).le.0)
3211 C end of changes suggested by Ana
3212      &    .or. itype(i+2).eq.ntyp1
3213      &    .or. itype(i+3).eq.ntyp1
3214 C     &    .or. itype(i+5).eq.ntyp1
3215 C     &    .or. itype(i).eq.ntyp1
3216 C     &    .or. itype(i-1).eq.ntyp1
3217      &    ) goto 179
3218
3219 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3220 C
3221 C               Third-order contributions
3222 C
3223 C                 (i+2)o----(i+3)
3224 C                      | |
3225 C                      | |
3226 C                 (i+1)o----i
3227 C
3228 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3229 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3230         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3231         call transpose2(auxmat(1,1),auxmat1(1,1))
3232         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3233         if (shield_mode.eq.0) then
3234         fac_shield(i)=1.0
3235         fac_shield(j)=1.0
3236 C        else
3237 C        fac_shield(i)=0.4
3238 C        fac_shield(j)=0.6
3239         endif
3240
3241         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3242      &  *fac_shield(i)*fac_shield(j)
3243      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3244
3245         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3246      &  *fac_shield(i)*fac_shield(j)
3247      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3248
3249 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3250 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3251 cd     &    ' eello_turn3_num',4*eello_turn3_num
3252         if (calc_grad) then
3253 C Derivatives in shield mode
3254           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3255      &  (shield_mode.gt.0)) then
3256 C          print *,i,j
3257
3258           do ilist=1,ishield_list(i)
3259            iresshield=shield_list(ilist,i)
3260            do k=1,3
3261            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3262 C     &      *2.0
3263            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3264      &              rlocshield
3265      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3266             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3267      &      +rlocshield
3268            enddo
3269           enddo
3270           do ilist=1,ishield_list(j)
3271            iresshield=shield_list(ilist,j)
3272            do k=1,3
3273            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3274 C     &     *2.0
3275            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3276      &              rlocshield
3277      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3278            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3279      &             +rlocshield
3280
3281            enddo
3282           enddo
3283
3284           do k=1,3
3285             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3286      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3287             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3288      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3289             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3290      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3291             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3292      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3293            enddo
3294            endif
3295
3296 C Derivatives in gamma(i)
3297         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3298         call transpose2(auxmat2(1,1),pizda(1,1))
3299         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3300         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3301      &   *fac_shield(i)*fac_shield(j)
3302      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3303
3304 C Derivatives in gamma(i+1)
3305         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3306         call transpose2(auxmat2(1,1),pizda(1,1))
3307         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3308         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3309      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3310      &   *fac_shield(i)*fac_shield(j)
3311      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3312
3313 C Cartesian derivatives
3314         do l=1,3
3315           a_temp(1,1)=aggi(l,1)
3316           a_temp(1,2)=aggi(l,2)
3317           a_temp(2,1)=aggi(l,3)
3318           a_temp(2,2)=aggi(l,4)
3319           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3320           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3321      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3322      &   *fac_shield(i)*fac_shield(j)
3323      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3324
3325           a_temp(1,1)=aggi1(l,1)
3326           a_temp(1,2)=aggi1(l,2)
3327           a_temp(2,1)=aggi1(l,3)
3328           a_temp(2,2)=aggi1(l,4)
3329           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3330           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3331      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3332      &   *fac_shield(i)*fac_shield(j)
3333      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3334
3335           a_temp(1,1)=aggj(l,1)
3336           a_temp(1,2)=aggj(l,2)
3337           a_temp(2,1)=aggj(l,3)
3338           a_temp(2,2)=aggj(l,4)
3339           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3340           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3341      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3342      &   *fac_shield(i)*fac_shield(j)
3343      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3344
3345           a_temp(1,1)=aggj1(l,1)
3346           a_temp(1,2)=aggj1(l,2)
3347           a_temp(2,1)=aggj1(l,3)
3348           a_temp(2,2)=aggj1(l,4)
3349           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3350           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3351      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3352      &   *fac_shield(i)*fac_shield(j)
3353      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3354
3355         enddo
3356         endif
3357   179 continue
3358       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3359       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3360 C changes suggested by Ana to avoid out of bounds
3361 C     & .or.((i+5).gt.nres)
3362 C     & .or.((i-1).le.0)
3363 C end of changes suggested by Ana
3364      &    .or. itype(i+3).eq.ntyp1
3365      &    .or. itype(i+4).eq.ntyp1
3366 C     &    .or. itype(i+5).eq.ntyp1
3367      &    .or. itype(i).eq.ntyp1
3368 C     &    .or. itype(i-1).eq.ntyp1
3369      &    ) goto 178
3370 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3371 C
3372 C               Fourth-order contributions
3373 C
3374 C                 (i+3)o----(i+4)
3375 C                     /  |
3376 C               (i+2)o   |
3377 C                     \  |
3378 C                 (i+1)o----i
3379 C
3380 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3381 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3382         iti1=itortyp(itype(i+1))
3383         iti2=itortyp(itype(i+2))
3384         iti3=itortyp(itype(i+3))
3385         call transpose2(EUg(1,1,i+1),e1t(1,1))
3386         call transpose2(Eug(1,1,i+2),e2t(1,1))
3387         call transpose2(Eug(1,1,i+3),e3t(1,1))
3388         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3389         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3390         s1=scalar2(b1(1,iti2),auxvec(1))
3391         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3392         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3393         s2=scalar2(b1(1,iti1),auxvec(1))
3394         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3395         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3396         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3397         if (shield_mode.eq.0) then
3398         fac_shield(i)=1.0
3399         fac_shield(j)=1.0
3400 C        else
3401 C        fac_shield(i)=0.4
3402 C        fac_shield(j)=0.6
3403         endif
3404
3405         eello_turn4=eello_turn4-(s1+s2+s3)
3406      &  *fac_shield(i)*fac_shield(j)
3407         eello_t4=-(s1+s2+s3)
3408      &  *fac_shield(i)*fac_shield(j)
3409
3410 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3411 cd     &    ' eello_turn4_num',8*eello_turn4_num
3412 C Derivatives in gamma(i)
3413         if (calc_grad) then
3414           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3415      &  (shield_mode.gt.0)) then
3416 C          print *,i,j
3417
3418           do ilist=1,ishield_list(i)
3419            iresshield=shield_list(ilist,i)
3420            do k=1,3
3421            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3422 C     &      *2.0
3423            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3424      &              rlocshield
3425      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3426             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3427      &      +rlocshield
3428            enddo
3429           enddo
3430           do ilist=1,ishield_list(j)
3431            iresshield=shield_list(ilist,j)
3432            do k=1,3
3433            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3434 C     &     *2.0
3435            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3436      &              rlocshield
3437      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3438            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3439      &             +rlocshield
3440
3441            enddo
3442           enddo
3443
3444           do k=1,3
3445             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3446      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3447             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3448      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3449             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3450      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3451             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3452      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3453            enddo
3454            endif
3455         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3456         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3457         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3458         s1=scalar2(b1(1,iti2),auxvec(1))
3459         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3460         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3461         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3462      &  *fac_shield(i)*fac_shield(j)
3463      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3464
3465 C Derivatives in gamma(i+1)
3466         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3467         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3468         s2=scalar2(b1(1,iti1),auxvec(1))
3469         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3470         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3471         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3472         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3473      &  *fac_shield(i)*fac_shield(j)
3474      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3475
3476 C Derivatives in gamma(i+2)
3477         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3478         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3479         s1=scalar2(b1(1,iti2),auxvec(1))
3480         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3481         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3482         s2=scalar2(b1(1,iti1),auxvec(1))
3483         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3484         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3485         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3486         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3487      &  *fac_shield(i)*fac_shield(j)
3488      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3489
3490 C Cartesian derivatives
3491
3492 C Derivatives of this turn contributions in DC(i+2)
3493         if (j.lt.nres-1) then
3494           do l=1,3
3495             a_temp(1,1)=agg(l,1)
3496             a_temp(1,2)=agg(l,2)
3497             a_temp(2,1)=agg(l,3)
3498             a_temp(2,2)=agg(l,4)
3499             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3500             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3501             s1=scalar2(b1(1,iti2),auxvec(1))
3502             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3503             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3504             s2=scalar2(b1(1,iti1),auxvec(1))
3505             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3506             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3507             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3508             ggg(l)=-(s1+s2+s3)
3509             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3510      &  *fac_shield(i)*fac_shield(j)
3511      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3512
3513           enddo
3514         endif
3515 C Remaining derivatives of this turn contribution
3516         do l=1,3
3517           a_temp(1,1)=aggi(l,1)
3518           a_temp(1,2)=aggi(l,2)
3519           a_temp(2,1)=aggi(l,3)
3520           a_temp(2,2)=aggi(l,4)
3521           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3522           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3523           s1=scalar2(b1(1,iti2),auxvec(1))
3524           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3525           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3526           s2=scalar2(b1(1,iti1),auxvec(1))
3527           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3528           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3529           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3530           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3531      &  *fac_shield(i)*fac_shield(j)
3532      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3533
3534           a_temp(1,1)=aggi1(l,1)
3535           a_temp(1,2)=aggi1(l,2)
3536           a_temp(2,1)=aggi1(l,3)
3537           a_temp(2,2)=aggi1(l,4)
3538           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3539           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3540           s1=scalar2(b1(1,iti2),auxvec(1))
3541           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3542           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3543           s2=scalar2(b1(1,iti1),auxvec(1))
3544           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3545           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3546           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3547           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3548      &  *fac_shield(i)*fac_shield(j)
3549      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3550
3551           a_temp(1,1)=aggj(l,1)
3552           a_temp(1,2)=aggj(l,2)
3553           a_temp(2,1)=aggj(l,3)
3554           a_temp(2,2)=aggj(l,4)
3555           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3556           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3557           s1=scalar2(b1(1,iti2),auxvec(1))
3558           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3559           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3560           s2=scalar2(b1(1,iti1),auxvec(1))
3561           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3562           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3563           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3564           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3565      &  *fac_shield(i)*fac_shield(j)
3566      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3567
3568           a_temp(1,1)=aggj1(l,1)
3569           a_temp(1,2)=aggj1(l,2)
3570           a_temp(2,1)=aggj1(l,3)
3571           a_temp(2,2)=aggj1(l,4)
3572           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3573           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3574           s1=scalar2(b1(1,iti2),auxvec(1))
3575           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3576           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3577           s2=scalar2(b1(1,iti1),auxvec(1))
3578           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3579           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3580           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3581           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3582      &  *fac_shield(i)*fac_shield(j)
3583      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3584
3585         enddo
3586          gshieldc_t4(3,i)=gshieldc_t4(3,i)+
3587      &     ssgradlipi*eello_t4/4.0d0*lipscale
3588          gshieldc_t4(3,j)=gshieldc_t4(3,j)+
3589      &     ssgradlipj*eello_t4/4.0d0*lipscale
3590          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
3591      &     ssgradlipi*eello_t4/4.0d0*lipscale
3592          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
3593      &     ssgradlipj*eello_t4/4.0d0*lipscale
3594         endif
3595  178  continue
3596       endif
3597       return
3598       end
3599 C-----------------------------------------------------------------------------
3600       subroutine vecpr(u,v,w)
3601       implicit real*8(a-h,o-z)
3602       dimension u(3),v(3),w(3)
3603       w(1)=u(2)*v(3)-u(3)*v(2)
3604       w(2)=-u(1)*v(3)+u(3)*v(1)
3605       w(3)=u(1)*v(2)-u(2)*v(1)
3606       return
3607       end
3608 C-----------------------------------------------------------------------------
3609       subroutine unormderiv(u,ugrad,unorm,ungrad)
3610 C This subroutine computes the derivatives of a normalized vector u, given
3611 C the derivatives computed without normalization conditions, ugrad. Returns
3612 C ungrad.
3613       implicit none
3614       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3615       double precision vec(3)
3616       double precision scalar
3617       integer i,j
3618 c      write (2,*) 'ugrad',ugrad
3619 c      write (2,*) 'u',u
3620       do i=1,3
3621         vec(i)=scalar(ugrad(1,i),u(1))
3622       enddo
3623 c      write (2,*) 'vec',vec
3624       do i=1,3
3625         do j=1,3
3626           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3627         enddo
3628       enddo
3629 c      write (2,*) 'ungrad',ungrad
3630       return
3631       end
3632 C-----------------------------------------------------------------------------
3633       subroutine escp(evdw2,evdw2_14)
3634 C
3635 C This subroutine calculates the excluded-volume interaction energy between
3636 C peptide-group centers and side chains and its gradient in virtual-bond and
3637 C side-chain vectors.
3638 C
3639       implicit real*8 (a-h,o-z)
3640       include 'DIMENSIONS'
3641       include 'DIMENSIONS.ZSCOPT'
3642       include 'COMMON.GEO'
3643       include 'COMMON.VAR'
3644       include 'COMMON.LOCAL'
3645       include 'COMMON.CHAIN'
3646       include 'COMMON.DERIV'
3647       include 'COMMON.INTERACT'
3648       include 'COMMON.FFIELD'
3649       include 'COMMON.IOUNITS'
3650       dimension ggg(3)
3651       evdw2=0.0D0
3652       evdw2_14=0.0d0
3653 cd    print '(a)','Enter ESCP'
3654 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3655 c     &  ' scal14',scal14
3656       do i=iatscp_s,iatscp_e
3657         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3658         iteli=itel(i)
3659 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3660 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3661         if (iteli.eq.0) goto 1225
3662         xi=0.5D0*(c(1,i)+c(1,i+1))
3663         yi=0.5D0*(c(2,i)+c(2,i+1))
3664         zi=0.5D0*(c(3,i)+c(3,i+1))
3665 C Returning the ith atom to box
3666           xi=mod(xi,boxxsize)
3667           if (xi.lt.0) xi=xi+boxxsize
3668           yi=mod(yi,boxysize)
3669           if (yi.lt.0) yi=yi+boxysize
3670           zi=mod(zi,boxzsize)
3671           if (zi.lt.0) zi=zi+boxzsize
3672         do iint=1,nscp_gr(i)
3673
3674         do j=iscpstart(i,iint),iscpend(i,iint)
3675           itypj=iabs(itype(j))
3676           if (itypj.eq.ntyp1) cycle
3677 C Uncomment following three lines for SC-p interactions
3678 c         xj=c(1,nres+j)-xi
3679 c         yj=c(2,nres+j)-yi
3680 c         zj=c(3,nres+j)-zi
3681 C Uncomment following three lines for Ca-p interactions
3682           xj=c(1,j)
3683           yj=c(2,j)
3684           zj=c(3,j)
3685 C returning the jth atom to box
3686           xj=mod(xj,boxxsize)
3687           if (xj.lt.0) xj=xj+boxxsize
3688           yj=mod(yj,boxysize)
3689           if (yj.lt.0) yj=yj+boxysize
3690           zj=mod(zj,boxzsize)
3691           if (zj.lt.0) zj=zj+boxzsize
3692       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3693       xj_safe=xj
3694       yj_safe=yj
3695       zj_safe=zj
3696       subchap=0
3697 C Finding the closest jth atom
3698       do xshift=-1,1
3699       do yshift=-1,1
3700       do zshift=-1,1
3701           xj=xj_safe+xshift*boxxsize
3702           yj=yj_safe+yshift*boxysize
3703           zj=zj_safe+zshift*boxzsize
3704           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3705           if(dist_temp.lt.dist_init) then
3706             dist_init=dist_temp
3707             xj_temp=xj
3708             yj_temp=yj
3709             zj_temp=zj
3710             subchap=1
3711           endif
3712        enddo
3713        enddo
3714        enddo
3715        if (subchap.eq.1) then
3716           xj=xj_temp-xi
3717           yj=yj_temp-yi
3718           zj=zj_temp-zi
3719        else
3720           xj=xj_safe-xi
3721           yj=yj_safe-yi
3722           zj=zj_safe-zi
3723        endif
3724           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3725 C sss is scaling function for smoothing the cutoff gradient otherwise
3726 C the gradient would not be continuouse
3727           sss=sscale(1.0d0/(dsqrt(rrij)))
3728           if (sss.le.0.0d0) cycle
3729           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3730           fac=rrij**expon2
3731           e1=fac*fac*aad(itypj,iteli)
3732           e2=fac*bad(itypj,iteli)
3733           if (iabs(j-i) .le. 2) then
3734             e1=scal14*e1
3735             e2=scal14*e2
3736             evdw2_14=evdw2_14+(e1+e2)*sss
3737           endif
3738           evdwij=e1+e2
3739 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3740 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3741 c     &       bad(itypj,iteli)
3742           evdw2=evdw2+evdwij*sss
3743           if (calc_grad) then
3744 C
3745 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3746 C
3747           fac=-(evdwij+e1)*rrij*sss
3748           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3749           ggg(1)=xj*fac
3750           ggg(2)=yj*fac
3751           ggg(3)=zj*fac
3752           if (j.lt.i) then
3753 cd          write (iout,*) 'j<i'
3754 C Uncomment following three lines for SC-p interactions
3755 c           do k=1,3
3756 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3757 c           enddo
3758           else
3759 cd          write (iout,*) 'j>i'
3760             do k=1,3
3761               ggg(k)=-ggg(k)
3762 C Uncomment following line for SC-p interactions
3763 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3764             enddo
3765           endif
3766           do k=1,3
3767             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3768           enddo
3769           kstart=min0(i+1,j)
3770           kend=max0(i-1,j-1)
3771 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3772 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3773           do k=kstart,kend
3774             do l=1,3
3775               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3776             enddo
3777           enddo
3778           endif
3779         enddo
3780         enddo ! iint
3781  1225   continue
3782       enddo ! i
3783       do i=1,nct
3784         do j=1,3
3785           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3786           gradx_scp(j,i)=expon*gradx_scp(j,i)
3787         enddo
3788       enddo
3789 C******************************************************************************
3790 C
3791 C                              N O T E !!!
3792 C
3793 C To save time the factor EXPON has been extracted from ALL components
3794 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3795 C use!
3796 C
3797 C******************************************************************************
3798       return
3799       end
3800 C--------------------------------------------------------------------------
3801       subroutine edis(ehpb)
3802 C
3803 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3804 C
3805       implicit real*8 (a-h,o-z)
3806       include 'DIMENSIONS'
3807       include 'DIMENSIONS.ZSCOPT'
3808       include 'COMMON.SBRIDGE'
3809       include 'COMMON.CHAIN'
3810       include 'COMMON.DERIV'
3811       include 'COMMON.VAR'
3812       include 'COMMON.INTERACT'
3813       include 'COMMON.CONTROL'
3814       include 'COMMON.IOUNITS'
3815       dimension ggg(3)
3816       ehpb=0.0D0
3817 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3818 cd    print *,'link_start=',link_start,' link_end=',link_end
3819 C      write(iout,*) link_end, "link_end"
3820       if (link_end.eq.0) return
3821       do i=link_start,link_end
3822 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3823 C CA-CA distance used in regularization of structure.
3824         ii=ihpb(i)
3825         jj=jhpb(i)
3826 C iii and jjj point to the residues for which the distance is assigned.
3827         if (ii.gt.nres) then
3828           iii=ii-nres
3829           jjj=jj-nres
3830         else
3831           iii=ii
3832           jjj=jj
3833         endif
3834 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3835 C    distance and angle dependent SS bond potential.
3836 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3837 C     & iabs(itype(jjj)).eq.1) then
3838 C       write(iout,*) constr_dist,"const"
3839        if (.not.dyn_ss .and. i.le.nss) then
3840          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3841      & iabs(itype(jjj)).eq.1) then
3842           call ssbond_ene(iii,jjj,eij)
3843           ehpb=ehpb+2*eij
3844            endif !ii.gt.neres
3845         else if (ii.gt.nres .and. jj.gt.nres) then
3846 c Restraints from contact prediction
3847           dd=dist(ii,jj)
3848           if (constr_dist.eq.11) then
3849 C            ehpb=ehpb+fordepth(i)**4.0d0
3850 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3851             ehpb=ehpb+fordepth(i)**4.0d0
3852      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3853             fac=fordepth(i)**4.0d0
3854      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3855 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3856 C     &    ehpb,fordepth(i),dd
3857 C            write(iout,*) ehpb,"atu?"
3858 C            ehpb,"tu?"
3859 C            fac=fordepth(i)**4.0d0
3860 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3861            else
3862           if (dhpb1(i).gt.0.0d0) then
3863             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3864             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3865 c            write (iout,*) "beta nmr",
3866 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3867           else
3868             dd=dist(ii,jj)
3869             rdis=dd-dhpb(i)
3870 C Get the force constant corresponding to this distance.
3871             waga=forcon(i)
3872 C Calculate the contribution to energy.
3873             ehpb=ehpb+waga*rdis*rdis
3874 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3875 C
3876 C Evaluate gradient.
3877 C
3878             fac=waga*rdis/dd
3879           endif !end dhpb1(i).gt.0
3880           endif !end const_dist=11
3881           do j=1,3
3882             ggg(j)=fac*(c(j,jj)-c(j,ii))
3883           enddo
3884           do j=1,3
3885             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3886             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3887           enddo
3888           do k=1,3
3889             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3890             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3891           enddo
3892         else !ii.gt.nres
3893 C          write(iout,*) "before"
3894           dd=dist(ii,jj)
3895 C          write(iout,*) "after",dd
3896           if (constr_dist.eq.11) then
3897             ehpb=ehpb+fordepth(i)**4.0d0
3898      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3899             fac=fordepth(i)**4.0d0
3900      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3901 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3902 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3903 C            print *,ehpb,"tu?"
3904 C            write(iout,*) ehpb,"btu?",
3905 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3906 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3907 C     &    ehpb,fordepth(i),dd
3908            else
3909           if (dhpb1(i).gt.0.0d0) then
3910             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3911             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3912 c            write (iout,*) "alph nmr",
3913 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3914           else
3915             rdis=dd-dhpb(i)
3916 C Get the force constant corresponding to this distance.
3917             waga=forcon(i)
3918 C Calculate the contribution to energy.
3919             ehpb=ehpb+waga*rdis*rdis
3920 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3921 C
3922 C Evaluate gradient.
3923 C
3924             fac=waga*rdis/dd
3925           endif
3926           endif
3927
3928         do j=1,3
3929           ggg(j)=fac*(c(j,jj)-c(j,ii))
3930         enddo
3931 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3932 C If this is a SC-SC distance, we need to calculate the contributions to the
3933 C Cartesian gradient in the SC vectors (ghpbx).
3934         if (iii.lt.ii) then
3935           do j=1,3
3936             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3937             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3938           enddo
3939         endif
3940         do j=iii,jjj-1
3941           do k=1,3
3942             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3943           enddo
3944         enddo
3945         endif
3946       enddo
3947       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3948       return
3949       end
3950 C--------------------------------------------------------------------------
3951       subroutine ssbond_ene(i,j,eij)
3952 C
3953 C Calculate the distance and angle dependent SS-bond potential energy
3954 C using a free-energy function derived based on RHF/6-31G** ab initio
3955 C calculations of diethyl disulfide.
3956 C
3957 C A. Liwo and U. Kozlowska, 11/24/03
3958 C
3959       implicit real*8 (a-h,o-z)
3960       include 'DIMENSIONS'
3961       include 'DIMENSIONS.ZSCOPT'
3962       include 'COMMON.SBRIDGE'
3963       include 'COMMON.CHAIN'
3964       include 'COMMON.DERIV'
3965       include 'COMMON.LOCAL'
3966       include 'COMMON.INTERACT'
3967       include 'COMMON.VAR'
3968       include 'COMMON.IOUNITS'
3969       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3970       itypi=iabs(itype(i))
3971       xi=c(1,nres+i)
3972       yi=c(2,nres+i)
3973       zi=c(3,nres+i)
3974       dxi=dc_norm(1,nres+i)
3975       dyi=dc_norm(2,nres+i)
3976       dzi=dc_norm(3,nres+i)
3977       dsci_inv=dsc_inv(itypi)
3978       itypj=iabs(itype(j))
3979       dscj_inv=dsc_inv(itypj)
3980       xj=c(1,nres+j)-xi
3981       yj=c(2,nres+j)-yi
3982       zj=c(3,nres+j)-zi
3983       dxj=dc_norm(1,nres+j)
3984       dyj=dc_norm(2,nres+j)
3985       dzj=dc_norm(3,nres+j)
3986       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3987       rij=dsqrt(rrij)
3988       erij(1)=xj*rij
3989       erij(2)=yj*rij
3990       erij(3)=zj*rij
3991       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3992       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3993       om12=dxi*dxj+dyi*dyj+dzi*dzj
3994       do k=1,3
3995         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3996         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3997       enddo
3998       rij=1.0d0/rij
3999       deltad=rij-d0cm
4000       deltat1=1.0d0-om1
4001       deltat2=1.0d0+om2
4002       deltat12=om2-om1+2.0d0
4003       cosphi=om12-om1*om2
4004       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4005      &  +akct*deltad*deltat12
4006      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4007 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4008 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4009 c     &  " deltat12",deltat12," eij",eij
4010       ed=2*akcm*deltad+akct*deltat12
4011       pom1=akct*deltad
4012       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4013       eom1=-2*akth*deltat1-pom1-om2*pom2
4014       eom2= 2*akth*deltat2+pom1-om1*pom2
4015       eom12=pom2
4016       do k=1,3
4017         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4018       enddo
4019       do k=1,3
4020         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4021      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4022         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4023      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4024       enddo
4025 C
4026 C Calculate the components of the gradient in DC and X
4027 C
4028       do k=i,j-1
4029         do l=1,3
4030           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4031         enddo
4032       enddo
4033       return
4034       end
4035 C--------------------------------------------------------------------------
4036       subroutine ebond(estr)
4037 c
4038 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4039 c
4040       implicit real*8 (a-h,o-z)
4041       include 'DIMENSIONS'
4042       include 'DIMENSIONS.ZSCOPT'
4043       include 'COMMON.LOCAL'
4044       include 'COMMON.GEO'
4045       include 'COMMON.INTERACT'
4046       include 'COMMON.DERIV'
4047       include 'COMMON.VAR'
4048       include 'COMMON.CHAIN'
4049       include 'COMMON.IOUNITS'
4050       include 'COMMON.NAMES'
4051       include 'COMMON.FFIELD'
4052       include 'COMMON.CONTROL'
4053       logical energy_dec /.false./
4054       double precision u(3),ud(3)
4055       estr=0.0d0
4056       estr1=0.0d0
4057 c      write (iout,*) "distchainmax",distchainmax
4058       do i=nnt+1,nct
4059         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4060 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4061 C          do j=1,3
4062 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4063 C     &      *dc(j,i-1)/vbld(i)
4064 C          enddo
4065 C          if (energy_dec) write(iout,*)
4066 C     &       "estr1",i,vbld(i),distchainmax,
4067 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4068 C        else
4069          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4070         diff = vbld(i)-vbldpDUM
4071 C         write(iout,*) i,diff
4072          else
4073           diff = vbld(i)-vbldp0
4074 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4075          endif
4076           estr=estr+diff*diff
4077           do j=1,3
4078             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4079           enddo
4080 C        endif
4081 C        write (iout,'(a7,i5,4f7.3)')
4082 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4083       enddo
4084       estr=0.5d0*AKP*estr+estr1
4085 c
4086 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4087 c
4088       do i=nnt,nct
4089         iti=iabs(itype(i))
4090         if (iti.ne.10 .and. iti.ne.ntyp1) then
4091           nbi=nbondterm(iti)
4092           if (nbi.eq.1) then
4093             diff=vbld(i+nres)-vbldsc0(1,iti)
4094 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4095 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4096             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4097             do j=1,3
4098               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4099             enddo
4100           else
4101             do j=1,nbi
4102               diff=vbld(i+nres)-vbldsc0(j,iti)
4103               ud(j)=aksc(j,iti)*diff
4104               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4105             enddo
4106             uprod=u(1)
4107             do j=2,nbi
4108               uprod=uprod*u(j)
4109             enddo
4110             usum=0.0d0
4111             usumsqder=0.0d0
4112             do j=1,nbi
4113               uprod1=1.0d0
4114               uprod2=1.0d0
4115               do k=1,nbi
4116                 if (k.ne.j) then
4117                   uprod1=uprod1*u(k)
4118                   uprod2=uprod2*u(k)*u(k)
4119                 endif
4120               enddo
4121               usum=usum+uprod1
4122               usumsqder=usumsqder+ud(j)*uprod2
4123             enddo
4124 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4125 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4126             estr=estr+uprod/usum
4127             do j=1,3
4128              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4129             enddo
4130           endif
4131         endif
4132       enddo
4133       return
4134       end
4135 #ifdef CRYST_THETA
4136 C--------------------------------------------------------------------------
4137       subroutine ebend(etheta,ethetacnstr)
4138 C
4139 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4140 C angles gamma and its derivatives in consecutive thetas and gammas.
4141 C
4142       implicit real*8 (a-h,o-z)
4143       include 'DIMENSIONS'
4144       include 'DIMENSIONS.ZSCOPT'
4145       include 'COMMON.LOCAL'
4146       include 'COMMON.GEO'
4147       include 'COMMON.INTERACT'
4148       include 'COMMON.DERIV'
4149       include 'COMMON.VAR'
4150       include 'COMMON.CHAIN'
4151       include 'COMMON.IOUNITS'
4152       include 'COMMON.NAMES'
4153       include 'COMMON.FFIELD'
4154       include 'COMMON.TORCNSTR'
4155       common /calcthet/ term1,term2,termm,diffak,ratak,
4156      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4157      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4158       double precision y(2),z(2)
4159       delta=0.02d0*pi
4160 c      time11=dexp(-2*time)
4161 c      time12=1.0d0
4162       etheta=0.0D0
4163 c      write (iout,*) "nres",nres
4164 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4165 c      write (iout,*) ithet_start,ithet_end
4166       do i=ithet_start,ithet_end
4167 C        if (itype(i-1).eq.ntyp1) cycle
4168         if (i.le.2) cycle
4169         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4170      &  .or.itype(i).eq.ntyp1) cycle
4171 C Zero the energy function and its derivative at 0 or pi.
4172         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4173         it=itype(i-1)
4174         ichir1=isign(1,itype(i-2))
4175         ichir2=isign(1,itype(i))
4176          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4177          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4178          if (itype(i-1).eq.10) then
4179           itype1=isign(10,itype(i-2))
4180           ichir11=isign(1,itype(i-2))
4181           ichir12=isign(1,itype(i-2))
4182           itype2=isign(10,itype(i))
4183           ichir21=isign(1,itype(i))
4184           ichir22=isign(1,itype(i))
4185          endif
4186          if (i.eq.3) then
4187           y(1)=0.0D0
4188           y(2)=0.0D0
4189           else
4190
4191         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4192 #ifdef OSF
4193           phii=phi(i)
4194 c          icrc=0
4195 c          call proc_proc(phii,icrc)
4196           if (icrc.eq.1) phii=150.0
4197 #else
4198           phii=phi(i)
4199 #endif
4200           y(1)=dcos(phii)
4201           y(2)=dsin(phii)
4202         else
4203           y(1)=0.0D0
4204           y(2)=0.0D0
4205         endif
4206         endif
4207         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4208 #ifdef OSF
4209           phii1=phi(i+1)
4210 c          icrc=0
4211 c          call proc_proc(phii1,icrc)
4212           if (icrc.eq.1) phii1=150.0
4213           phii1=pinorm(phii1)
4214           z(1)=cos(phii1)
4215 #else
4216           phii1=phi(i+1)
4217           z(1)=dcos(phii1)
4218 #endif
4219           z(2)=dsin(phii1)
4220         else
4221           z(1)=0.0D0
4222           z(2)=0.0D0
4223         endif
4224 C Calculate the "mean" value of theta from the part of the distribution
4225 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4226 C In following comments this theta will be referred to as t_c.
4227         thet_pred_mean=0.0d0
4228         do k=1,2
4229             athetk=athet(k,it,ichir1,ichir2)
4230             bthetk=bthet(k,it,ichir1,ichir2)
4231           if (it.eq.10) then
4232              athetk=athet(k,itype1,ichir11,ichir12)
4233              bthetk=bthet(k,itype2,ichir21,ichir22)
4234           endif
4235           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4236         enddo
4237 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4238         dthett=thet_pred_mean*ssd
4239         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4240 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4241 C Derivatives of the "mean" values in gamma1 and gamma2.
4242         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4243      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4244          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4245      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4246          if (it.eq.10) then
4247       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4248      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4249         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4250      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4251          endif
4252         if (theta(i).gt.pi-delta) then
4253           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4254      &         E_tc0)
4255           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4256           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4257           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4258      &        E_theta)
4259           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4260      &        E_tc)
4261         else if (theta(i).lt.delta) then
4262           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4263           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4264           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4265      &        E_theta)
4266           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4267           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4268      &        E_tc)
4269         else
4270           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4271      &        E_theta,E_tc)
4272         endif
4273         etheta=etheta+ethetai
4274 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4275 c     &      'ebend',i,ethetai,theta(i),itype(i)
4276 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4277 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4278         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4279         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4280         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4281 c 1215   continue
4282       enddo
4283       ethetacnstr=0.0d0
4284 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4285       do i=1,ntheta_constr
4286         itheta=itheta_constr(i)
4287         thetiii=theta(itheta)
4288         difi=pinorm(thetiii-theta_constr0(i))
4289         if (difi.gt.theta_drange(i)) then
4290           difi=difi-theta_drange(i)
4291           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4292           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4293      &    +for_thet_constr(i)*difi**3
4294         else if (difi.lt.-drange(i)) then
4295           difi=difi+drange(i)
4296           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4297           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4298      &    +for_thet_constr(i)*difi**3
4299         else
4300           difi=0.0
4301         endif
4302 C       if (energy_dec) then
4303 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4304 C     &    i,itheta,rad2deg*thetiii,
4305 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4306 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4307 C     &    gloc(itheta+nphi-2,icg)
4308 C        endif
4309       enddo
4310 C Ufff.... We've done all this!!!
4311       return
4312       end
4313 C---------------------------------------------------------------------------
4314       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4315      &     E_tc)
4316       implicit real*8 (a-h,o-z)
4317       include 'DIMENSIONS'
4318       include 'COMMON.LOCAL'
4319       include 'COMMON.IOUNITS'
4320       common /calcthet/ term1,term2,termm,diffak,ratak,
4321      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4322      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4323 C Calculate the contributions to both Gaussian lobes.
4324 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4325 C The "polynomial part" of the "standard deviation" of this part of
4326 C the distribution.
4327         sig=polthet(3,it)
4328         do j=2,0,-1
4329           sig=sig*thet_pred_mean+polthet(j,it)
4330         enddo
4331 C Derivative of the "interior part" of the "standard deviation of the"
4332 C gamma-dependent Gaussian lobe in t_c.
4333         sigtc=3*polthet(3,it)
4334         do j=2,1,-1
4335           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4336         enddo
4337         sigtc=sig*sigtc
4338 C Set the parameters of both Gaussian lobes of the distribution.
4339 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4340         fac=sig*sig+sigc0(it)
4341         sigcsq=fac+fac
4342         sigc=1.0D0/sigcsq
4343 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4344         sigsqtc=-4.0D0*sigcsq*sigtc
4345 c       print *,i,sig,sigtc,sigsqtc
4346 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4347         sigtc=-sigtc/(fac*fac)
4348 C Following variable is sigma(t_c)**(-2)
4349         sigcsq=sigcsq*sigcsq
4350         sig0i=sig0(it)
4351         sig0inv=1.0D0/sig0i**2
4352         delthec=thetai-thet_pred_mean
4353         delthe0=thetai-theta0i
4354         term1=-0.5D0*sigcsq*delthec*delthec
4355         term2=-0.5D0*sig0inv*delthe0*delthe0
4356 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4357 C NaNs in taking the logarithm. We extract the largest exponent which is added
4358 C to the energy (this being the log of the distribution) at the end of energy
4359 C term evaluation for this virtual-bond angle.
4360         if (term1.gt.term2) then
4361           termm=term1
4362           term2=dexp(term2-termm)
4363           term1=1.0d0
4364         else
4365           termm=term2
4366           term1=dexp(term1-termm)
4367           term2=1.0d0
4368         endif
4369 C The ratio between the gamma-independent and gamma-dependent lobes of
4370 C the distribution is a Gaussian function of thet_pred_mean too.
4371         diffak=gthet(2,it)-thet_pred_mean
4372         ratak=diffak/gthet(3,it)**2
4373         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4374 C Let's differentiate it in thet_pred_mean NOW.
4375         aktc=ak*ratak
4376 C Now put together the distribution terms to make complete distribution.
4377         termexp=term1+ak*term2
4378         termpre=sigc+ak*sig0i
4379 C Contribution of the bending energy from this theta is just the -log of
4380 C the sum of the contributions from the two lobes and the pre-exponential
4381 C factor. Simple enough, isn't it?
4382         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4383 C NOW the derivatives!!!
4384 C 6/6/97 Take into account the deformation.
4385         E_theta=(delthec*sigcsq*term1
4386      &       +ak*delthe0*sig0inv*term2)/termexp
4387         E_tc=((sigtc+aktc*sig0i)/termpre
4388      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4389      &       aktc*term2)/termexp)
4390       return
4391       end
4392 c-----------------------------------------------------------------------------
4393       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4394       implicit real*8 (a-h,o-z)
4395       include 'DIMENSIONS'
4396       include 'COMMON.LOCAL'
4397       include 'COMMON.IOUNITS'
4398       common /calcthet/ term1,term2,termm,diffak,ratak,
4399      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4400      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4401       delthec=thetai-thet_pred_mean
4402       delthe0=thetai-theta0i
4403 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4404       t3 = thetai-thet_pred_mean
4405       t6 = t3**2
4406       t9 = term1
4407       t12 = t3*sigcsq
4408       t14 = t12+t6*sigsqtc
4409       t16 = 1.0d0
4410       t21 = thetai-theta0i
4411       t23 = t21**2
4412       t26 = term2
4413       t27 = t21*t26
4414       t32 = termexp
4415       t40 = t32**2
4416       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4417      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4418      & *(-t12*t9-ak*sig0inv*t27)
4419       return
4420       end
4421 #else
4422 C--------------------------------------------------------------------------
4423       subroutine ebend(etheta,ethetacnstr)
4424 C
4425 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4426 C angles gamma and its derivatives in consecutive thetas and gammas.
4427 C ab initio-derived potentials from
4428 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4429 C
4430       implicit real*8 (a-h,o-z)
4431       include 'DIMENSIONS'
4432       include 'DIMENSIONS.ZSCOPT'
4433       include 'COMMON.LOCAL'
4434       include 'COMMON.GEO'
4435       include 'COMMON.INTERACT'
4436       include 'COMMON.DERIV'
4437       include 'COMMON.VAR'
4438       include 'COMMON.CHAIN'
4439       include 'COMMON.IOUNITS'
4440       include 'COMMON.NAMES'
4441       include 'COMMON.FFIELD'
4442       include 'COMMON.CONTROL'
4443       include 'COMMON.TORCNSTR'
4444       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4445      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4446      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4447      & sinph1ph2(maxdouble,maxdouble)
4448       logical lprn /.false./, lprn1 /.false./
4449       etheta=0.0D0
4450 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4451       do i=ithet_start,ithet_end
4452 C         if (i.eq.2) cycle
4453 C        if (itype(i-1).eq.ntyp1) cycle
4454         if (i.le.2) cycle
4455         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4456      &  .or.itype(i).eq.ntyp1) cycle
4457         if (iabs(itype(i+1)).eq.20) iblock=2
4458         if (iabs(itype(i+1)).ne.20) iblock=1
4459         dethetai=0.0d0
4460         dephii=0.0d0
4461         dephii1=0.0d0
4462         theti2=0.5d0*theta(i)
4463         ityp2=ithetyp((itype(i-1)))
4464         do k=1,nntheterm
4465           coskt(k)=dcos(k*theti2)
4466           sinkt(k)=dsin(k*theti2)
4467         enddo
4468         if (i.eq.3) then
4469           phii=0.0d0
4470           ityp1=nthetyp+1
4471           do k=1,nsingle
4472             cosph1(k)=0.0d0
4473             sinph1(k)=0.0d0
4474           enddo
4475         else
4476         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4477 #ifdef OSF
4478           phii=phi(i)
4479           if (phii.ne.phii) phii=150.0
4480 #else
4481           phii=phi(i)
4482 #endif
4483           ityp1=ithetyp((itype(i-2)))
4484           do k=1,nsingle
4485             cosph1(k)=dcos(k*phii)
4486             sinph1(k)=dsin(k*phii)
4487           enddo
4488         else
4489           phii=0.0d0
4490 c          ityp1=nthetyp+1
4491           do k=1,nsingle
4492             ityp1=ithetyp((itype(i-2)))
4493             cosph1(k)=0.0d0
4494             sinph1(k)=0.0d0
4495           enddo
4496         endif
4497         endif
4498         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4499 #ifdef OSF
4500           phii1=phi(i+1)
4501           if (phii1.ne.phii1) phii1=150.0
4502           phii1=pinorm(phii1)
4503 #else
4504           phii1=phi(i+1)
4505 #endif
4506           ityp3=ithetyp((itype(i)))
4507           do k=1,nsingle
4508             cosph2(k)=dcos(k*phii1)
4509             sinph2(k)=dsin(k*phii1)
4510           enddo
4511         else
4512           phii1=0.0d0
4513 c          ityp3=nthetyp+1
4514           ityp3=ithetyp((itype(i)))
4515           do k=1,nsingle
4516             cosph2(k)=0.0d0
4517             sinph2(k)=0.0d0
4518           enddo
4519         endif
4520 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4521 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4522 c        call flush(iout)
4523         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4524         do k=1,ndouble
4525           do l=1,k-1
4526             ccl=cosph1(l)*cosph2(k-l)
4527             ssl=sinph1(l)*sinph2(k-l)
4528             scl=sinph1(l)*cosph2(k-l)
4529             csl=cosph1(l)*sinph2(k-l)
4530             cosph1ph2(l,k)=ccl-ssl
4531             cosph1ph2(k,l)=ccl+ssl
4532             sinph1ph2(l,k)=scl+csl
4533             sinph1ph2(k,l)=scl-csl
4534           enddo
4535         enddo
4536         if (lprn) then
4537         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4538      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4539         write (iout,*) "coskt and sinkt"
4540         do k=1,nntheterm
4541           write (iout,*) k,coskt(k),sinkt(k)
4542         enddo
4543         endif
4544         do k=1,ntheterm
4545           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4546           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4547      &      *coskt(k)
4548           if (lprn)
4549      &    write (iout,*) "k",k,"
4550      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4551      &     " ethetai",ethetai
4552         enddo
4553         if (lprn) then
4554         write (iout,*) "cosph and sinph"
4555         do k=1,nsingle
4556           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4557         enddo
4558         write (iout,*) "cosph1ph2 and sinph2ph2"
4559         do k=2,ndouble
4560           do l=1,k-1
4561             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4562      &         sinph1ph2(l,k),sinph1ph2(k,l)
4563           enddo
4564         enddo
4565         write(iout,*) "ethetai",ethetai
4566         endif
4567         do m=1,ntheterm2
4568           do k=1,nsingle
4569             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4570      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4571      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4572      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4573             ethetai=ethetai+sinkt(m)*aux
4574             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4575             dephii=dephii+k*sinkt(m)*(
4576      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4577      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4578             dephii1=dephii1+k*sinkt(m)*(
4579      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4580      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4581             if (lprn)
4582      &      write (iout,*) "m",m," k",k," bbthet",
4583      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4584      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4585      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4586      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4587           enddo
4588         enddo
4589         if (lprn)
4590      &  write(iout,*) "ethetai",ethetai
4591         do m=1,ntheterm3
4592           do k=2,ndouble
4593             do l=1,k-1
4594               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4595      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4596      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4597      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4598               ethetai=ethetai+sinkt(m)*aux
4599               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4600               dephii=dephii+l*sinkt(m)*(
4601      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4602      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4603      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4604      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4605               dephii1=dephii1+(k-l)*sinkt(m)*(
4606      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4607      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4608      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4609      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4610               if (lprn) then
4611               write (iout,*) "m",m," k",k," l",l," ffthet",
4612      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4613      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4614      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4615      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4616      &            " ethetai",ethetai
4617               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4618      &            cosph1ph2(k,l)*sinkt(m),
4619      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4620               endif
4621             enddo
4622           enddo
4623         enddo
4624 10      continue
4625         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4626      &   i,theta(i)*rad2deg,phii*rad2deg,
4627      &   phii1*rad2deg,ethetai
4628         etheta=etheta+ethetai
4629         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4630         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4631 c        gloc(nphi+i-2,icg)=wang*dethetai
4632         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4633       enddo
4634 C now constrains
4635       ethetacnstr=0.0d0
4636 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4637       do i=1,ntheta_constr
4638         itheta=itheta_constr(i)
4639         thetiii=theta(itheta)
4640         difi=pinorm(thetiii-theta_constr0(i))
4641         if (difi.gt.theta_drange(i)) then
4642           difi=difi-theta_drange(i)
4643           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4644           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4645      &    +for_thet_constr(i)*difi**3
4646         else if (difi.lt.-drange(i)) then
4647           difi=difi+drange(i)
4648           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4649           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4650      &    +for_thet_constr(i)*difi**3
4651         else
4652           difi=0.0
4653         endif
4654 C       if (energy_dec) then
4655 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4656 C     &    i,itheta,rad2deg*thetiii,
4657 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4658 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4659 C     &    gloc(itheta+nphi-2,icg)
4660 C        endif
4661       enddo
4662       return
4663       end
4664 #endif
4665 #ifdef CRYST_SC
4666 c-----------------------------------------------------------------------------
4667       subroutine esc(escloc)
4668 C Calculate the local energy of a side chain and its derivatives in the
4669 C corresponding virtual-bond valence angles THETA and the spherical angles
4670 C ALPHA and OMEGA.
4671       implicit real*8 (a-h,o-z)
4672       include 'DIMENSIONS'
4673       include 'DIMENSIONS.ZSCOPT'
4674       include 'COMMON.GEO'
4675       include 'COMMON.LOCAL'
4676       include 'COMMON.VAR'
4677       include 'COMMON.INTERACT'
4678       include 'COMMON.DERIV'
4679       include 'COMMON.CHAIN'
4680       include 'COMMON.IOUNITS'
4681       include 'COMMON.NAMES'
4682       include 'COMMON.FFIELD'
4683       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4684      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4685       common /sccalc/ time11,time12,time112,theti,it,nlobit
4686       delta=0.02d0*pi
4687       escloc=0.0D0
4688 C      write (iout,*) 'ESC'
4689       do i=loc_start,loc_end
4690         it=itype(i)
4691         if (it.eq.ntyp1) cycle
4692         if (it.eq.10) goto 1
4693         nlobit=nlob(iabs(it))
4694 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4695 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4696         theti=theta(i+1)-pipol
4697         x(1)=dtan(theti)
4698         x(2)=alph(i)
4699         x(3)=omeg(i)
4700 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4701
4702         if (x(2).gt.pi-delta) then
4703           xtemp(1)=x(1)
4704           xtemp(2)=pi-delta
4705           xtemp(3)=x(3)
4706           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4707           xtemp(2)=pi
4708           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4709           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4710      &        escloci,dersc(2))
4711           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4712      &        ddersc0(1),dersc(1))
4713           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4714      &        ddersc0(3),dersc(3))
4715           xtemp(2)=pi-delta
4716           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4717           xtemp(2)=pi
4718           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4719           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4720      &            dersc0(2),esclocbi,dersc02)
4721           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4722      &            dersc12,dersc01)
4723           call splinthet(x(2),0.5d0*delta,ss,ssd)
4724           dersc0(1)=dersc01
4725           dersc0(2)=dersc02
4726           dersc0(3)=0.0d0
4727           do k=1,3
4728             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4729           enddo
4730           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4731           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4732      &             esclocbi,ss,ssd
4733           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4734 c         escloci=esclocbi
4735 c         write (iout,*) escloci
4736         else if (x(2).lt.delta) then
4737           xtemp(1)=x(1)
4738           xtemp(2)=delta
4739           xtemp(3)=x(3)
4740           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4741           xtemp(2)=0.0d0
4742           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4743           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4744      &        escloci,dersc(2))
4745           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4746      &        ddersc0(1),dersc(1))
4747           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4748      &        ddersc0(3),dersc(3))
4749           xtemp(2)=delta
4750           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4751           xtemp(2)=0.0d0
4752           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4753           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4754      &            dersc0(2),esclocbi,dersc02)
4755           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4756      &            dersc12,dersc01)
4757           dersc0(1)=dersc01
4758           dersc0(2)=dersc02
4759           dersc0(3)=0.0d0
4760           call splinthet(x(2),0.5d0*delta,ss,ssd)
4761           do k=1,3
4762             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4763           enddo
4764           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4765 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4766 c     &             esclocbi,ss,ssd
4767           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4768 C         write (iout,*) 'i=',i, escloci
4769         else
4770           call enesc(x,escloci,dersc,ddummy,.false.)
4771         endif
4772
4773         escloc=escloc+escloci
4774 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4775             write (iout,'(a6,i5,0pf7.3)')
4776      &     'escloc',i,escloci
4777
4778         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4779      &   wscloc*dersc(1)
4780         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4781         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4782     1   continue
4783       enddo
4784       return
4785       end
4786 C---------------------------------------------------------------------------
4787       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4788       implicit real*8 (a-h,o-z)
4789       include 'DIMENSIONS'
4790       include 'COMMON.GEO'
4791       include 'COMMON.LOCAL'
4792       include 'COMMON.IOUNITS'
4793       common /sccalc/ time11,time12,time112,theti,it,nlobit
4794       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4795       double precision contr(maxlob,-1:1)
4796       logical mixed
4797 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4798         escloc_i=0.0D0
4799         do j=1,3
4800           dersc(j)=0.0D0
4801           if (mixed) ddersc(j)=0.0d0
4802         enddo
4803         x3=x(3)
4804
4805 C Because of periodicity of the dependence of the SC energy in omega we have
4806 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4807 C To avoid underflows, first compute & store the exponents.
4808
4809         do iii=-1,1
4810
4811           x(3)=x3+iii*dwapi
4812
4813           do j=1,nlobit
4814             do k=1,3
4815               z(k)=x(k)-censc(k,j,it)
4816             enddo
4817             do k=1,3
4818               Axk=0.0D0
4819               do l=1,3
4820                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4821               enddo
4822               Ax(k,j,iii)=Axk
4823             enddo
4824             expfac=0.0D0
4825             do k=1,3
4826               expfac=expfac+Ax(k,j,iii)*z(k)
4827             enddo
4828             contr(j,iii)=expfac
4829           enddo ! j
4830
4831         enddo ! iii
4832
4833         x(3)=x3
4834 C As in the case of ebend, we want to avoid underflows in exponentiation and
4835 C subsequent NaNs and INFs in energy calculation.
4836 C Find the largest exponent
4837         emin=contr(1,-1)
4838         do iii=-1,1
4839           do j=1,nlobit
4840             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4841           enddo
4842         enddo
4843         emin=0.5D0*emin
4844 cd      print *,'it=',it,' emin=',emin
4845
4846 C Compute the contribution to SC energy and derivatives
4847         do iii=-1,1
4848
4849           do j=1,nlobit
4850             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4851 cd          print *,'j=',j,' expfac=',expfac
4852             escloc_i=escloc_i+expfac
4853             do k=1,3
4854               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4855             enddo
4856             if (mixed) then
4857               do k=1,3,2
4858                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4859      &            +gaussc(k,2,j,it))*expfac
4860               enddo
4861             endif
4862           enddo
4863
4864         enddo ! iii
4865
4866         dersc(1)=dersc(1)/cos(theti)**2
4867         ddersc(1)=ddersc(1)/cos(theti)**2
4868         ddersc(3)=ddersc(3)
4869
4870         escloci=-(dlog(escloc_i)-emin)
4871         do j=1,3
4872           dersc(j)=dersc(j)/escloc_i
4873         enddo
4874         if (mixed) then
4875           do j=1,3,2
4876             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4877           enddo
4878         endif
4879       return
4880       end
4881 C------------------------------------------------------------------------------
4882       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4883       implicit real*8 (a-h,o-z)
4884       include 'DIMENSIONS'
4885       include 'COMMON.GEO'
4886       include 'COMMON.LOCAL'
4887       include 'COMMON.IOUNITS'
4888       common /sccalc/ time11,time12,time112,theti,it,nlobit
4889       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4890       double precision contr(maxlob)
4891       logical mixed
4892
4893       escloc_i=0.0D0
4894
4895       do j=1,3
4896         dersc(j)=0.0D0
4897       enddo
4898
4899       do j=1,nlobit
4900         do k=1,2
4901           z(k)=x(k)-censc(k,j,it)
4902         enddo
4903         z(3)=dwapi
4904         do k=1,3
4905           Axk=0.0D0
4906           do l=1,3
4907             Axk=Axk+gaussc(l,k,j,it)*z(l)
4908           enddo
4909           Ax(k,j)=Axk
4910         enddo
4911         expfac=0.0D0
4912         do k=1,3
4913           expfac=expfac+Ax(k,j)*z(k)
4914         enddo
4915         contr(j)=expfac
4916       enddo ! j
4917
4918 C As in the case of ebend, we want to avoid underflows in exponentiation and
4919 C subsequent NaNs and INFs in energy calculation.
4920 C Find the largest exponent
4921       emin=contr(1)
4922       do j=1,nlobit
4923         if (emin.gt.contr(j)) emin=contr(j)
4924       enddo
4925       emin=0.5D0*emin
4926
4927 C Compute the contribution to SC energy and derivatives
4928
4929       dersc12=0.0d0
4930       do j=1,nlobit
4931         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4932         escloc_i=escloc_i+expfac
4933         do k=1,2
4934           dersc(k)=dersc(k)+Ax(k,j)*expfac
4935         enddo
4936         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4937      &            +gaussc(1,2,j,it))*expfac
4938         dersc(3)=0.0d0
4939       enddo
4940
4941       dersc(1)=dersc(1)/cos(theti)**2
4942       dersc12=dersc12/cos(theti)**2
4943       escloci=-(dlog(escloc_i)-emin)
4944       do j=1,2
4945         dersc(j)=dersc(j)/escloc_i
4946       enddo
4947       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4948       return
4949       end
4950 #else
4951 c----------------------------------------------------------------------------------
4952       subroutine esc(escloc)
4953 C Calculate the local energy of a side chain and its derivatives in the
4954 C corresponding virtual-bond valence angles THETA and the spherical angles
4955 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4956 C added by Urszula Kozlowska. 07/11/2007
4957 C
4958       implicit real*8 (a-h,o-z)
4959       include 'DIMENSIONS'
4960       include 'DIMENSIONS.ZSCOPT'
4961       include 'COMMON.GEO'
4962       include 'COMMON.LOCAL'
4963       include 'COMMON.VAR'
4964       include 'COMMON.SCROT'
4965       include 'COMMON.INTERACT'
4966       include 'COMMON.DERIV'
4967       include 'COMMON.CHAIN'
4968       include 'COMMON.IOUNITS'
4969       include 'COMMON.NAMES'
4970       include 'COMMON.FFIELD'
4971       include 'COMMON.CONTROL'
4972       include 'COMMON.VECTORS'
4973       double precision x_prime(3),y_prime(3),z_prime(3)
4974      &    , sumene,dsc_i,dp2_i,x(65),
4975      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4976      &    de_dxx,de_dyy,de_dzz,de_dt
4977       double precision s1_t,s1_6_t,s2_t,s2_6_t
4978       double precision
4979      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4980      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4981      & dt_dCi(3),dt_dCi1(3)
4982       common /sccalc/ time11,time12,time112,theti,it,nlobit
4983       delta=0.02d0*pi
4984       escloc=0.0D0
4985       do i=loc_start,loc_end
4986         if (itype(i).eq.ntyp1) cycle
4987         costtab(i+1) =dcos(theta(i+1))
4988         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4989         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4990         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4991         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4992         cosfac=dsqrt(cosfac2)
4993         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4994         sinfac=dsqrt(sinfac2)
4995         it=iabs(itype(i))
4996         if (it.eq.10) goto 1
4997 c
4998 C  Compute the axes of tghe local cartesian coordinates system; store in
4999 c   x_prime, y_prime and z_prime
5000 c
5001         do j=1,3
5002           x_prime(j) = 0.00
5003           y_prime(j) = 0.00
5004           z_prime(j) = 0.00
5005         enddo
5006 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5007 C     &   dc_norm(3,i+nres)
5008         do j = 1,3
5009           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5010           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5011         enddo
5012         do j = 1,3
5013           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5014         enddo
5015 c       write (2,*) "i",i
5016 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5017 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5018 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5019 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5020 c      & " xy",scalar(x_prime(1),y_prime(1)),
5021 c      & " xz",scalar(x_prime(1),z_prime(1)),
5022 c      & " yy",scalar(y_prime(1),y_prime(1)),
5023 c      & " yz",scalar(y_prime(1),z_prime(1)),
5024 c      & " zz",scalar(z_prime(1),z_prime(1))
5025 c
5026 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5027 C to local coordinate system. Store in xx, yy, zz.
5028 c
5029         xx=0.0d0
5030         yy=0.0d0
5031         zz=0.0d0
5032         do j = 1,3
5033           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5034           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5035           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5036         enddo
5037
5038         xxtab(i)=xx
5039         yytab(i)=yy
5040         zztab(i)=zz
5041 C
5042 C Compute the energy of the ith side cbain
5043 C
5044 c        write (2,*) "xx",xx," yy",yy," zz",zz
5045         it=iabs(itype(i))
5046         do j = 1,65
5047           x(j) = sc_parmin(j,it)
5048         enddo
5049 #ifdef CHECK_COORD
5050 Cc diagnostics - remove later
5051         xx1 = dcos(alph(2))
5052         yy1 = dsin(alph(2))*dcos(omeg(2))
5053         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5054         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5055      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5056      &    xx1,yy1,zz1
5057 C,"  --- ", xx_w,yy_w,zz_w
5058 c end diagnostics
5059 #endif
5060         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5061      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5062      &   + x(10)*yy*zz
5063         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5064      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5065      & + x(20)*yy*zz
5066         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5067      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5068      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5069      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5070      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5071      &  +x(40)*xx*yy*zz
5072         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5073      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5074      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5075      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5076      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5077      &  +x(60)*xx*yy*zz
5078         dsc_i   = 0.743d0+x(61)
5079         dp2_i   = 1.9d0+x(62)
5080         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5081      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5082         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5083      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5084         s1=(1+x(63))/(0.1d0 + dscp1)
5085         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5086         s2=(1+x(65))/(0.1d0 + dscp2)
5087         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5088         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5089      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5090 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5091 c     &   sumene4,
5092 c     &   dscp1,dscp2,sumene
5093 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5094         escloc = escloc + sumene
5095 c        write (2,*) "escloc",escloc
5096 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5097 c     &  zz,xx,yy
5098         if (.not. calc_grad) goto 1
5099 #ifdef DEBUG
5100 C
5101 C This section to check the numerical derivatives of the energy of ith side
5102 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5103 C #define DEBUG in the code to turn it on.
5104 C
5105         write (2,*) "sumene               =",sumene
5106         aincr=1.0d-7
5107         xxsave=xx
5108         xx=xx+aincr
5109         write (2,*) xx,yy,zz
5110         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5111         de_dxx_num=(sumenep-sumene)/aincr
5112         xx=xxsave
5113         write (2,*) "xx+ sumene from enesc=",sumenep
5114         yysave=yy
5115         yy=yy+aincr
5116         write (2,*) xx,yy,zz
5117         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5118         de_dyy_num=(sumenep-sumene)/aincr
5119         yy=yysave
5120         write (2,*) "yy+ sumene from enesc=",sumenep
5121         zzsave=zz
5122         zz=zz+aincr
5123         write (2,*) xx,yy,zz
5124         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5125         de_dzz_num=(sumenep-sumene)/aincr
5126         zz=zzsave
5127         write (2,*) "zz+ sumene from enesc=",sumenep
5128         costsave=cost2tab(i+1)
5129         sintsave=sint2tab(i+1)
5130         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5131         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5132         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5133         de_dt_num=(sumenep-sumene)/aincr
5134         write (2,*) " t+ sumene from enesc=",sumenep
5135         cost2tab(i+1)=costsave
5136         sint2tab(i+1)=sintsave
5137 C End of diagnostics section.
5138 #endif
5139 C
5140 C Compute the gradient of esc
5141 C
5142         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5143         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5144         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5145         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5146         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5147         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5148         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5149         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5150         pom1=(sumene3*sint2tab(i+1)+sumene1)
5151      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5152         pom2=(sumene4*cost2tab(i+1)+sumene2)
5153      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5154         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5155         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5156      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5157      &  +x(40)*yy*zz
5158         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5159         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5160      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5161      &  +x(60)*yy*zz
5162         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5163      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5164      &        +(pom1+pom2)*pom_dx
5165 #ifdef DEBUG
5166         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5167 #endif
5168 C
5169         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5170         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5171      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5172      &  +x(40)*xx*zz
5173         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5174         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5175      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5176      &  +x(59)*zz**2 +x(60)*xx*zz
5177         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5178      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5179      &        +(pom1-pom2)*pom_dy
5180 #ifdef DEBUG
5181         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5182 #endif
5183 C
5184         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5185      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5186      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5187      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5188      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5189      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5190      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5191      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5192 #ifdef DEBUG
5193         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5194 #endif
5195 C
5196         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5197      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5198      &  +pom1*pom_dt1+pom2*pom_dt2
5199 #ifdef DEBUG
5200         write(2,*), "de_dt = ", de_dt,de_dt_num
5201 #endif
5202 c
5203 C
5204        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5205        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5206        cosfac2xx=cosfac2*xx
5207        sinfac2yy=sinfac2*yy
5208        do k = 1,3
5209          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5210      &      vbld_inv(i+1)
5211          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5212      &      vbld_inv(i)
5213          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5214          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5215 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5216 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5217 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5218 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5219          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5220          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5221          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5222          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5223          dZZ_Ci1(k)=0.0d0
5224          dZZ_Ci(k)=0.0d0
5225          do j=1,3
5226            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5227      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5228            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5229      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5230          enddo
5231
5232          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5233          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5234          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5235 c
5236          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5237          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5238        enddo
5239
5240        do k=1,3
5241          dXX_Ctab(k,i)=dXX_Ci(k)
5242          dXX_C1tab(k,i)=dXX_Ci1(k)
5243          dYY_Ctab(k,i)=dYY_Ci(k)
5244          dYY_C1tab(k,i)=dYY_Ci1(k)
5245          dZZ_Ctab(k,i)=dZZ_Ci(k)
5246          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5247          dXX_XYZtab(k,i)=dXX_XYZ(k)
5248          dYY_XYZtab(k,i)=dYY_XYZ(k)
5249          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5250        enddo
5251
5252        do k = 1,3
5253 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5254 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5255 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5256 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5257 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5258 c     &    dt_dci(k)
5259 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5260 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5261          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5262      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5263          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5264      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5265          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5266      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5267        enddo
5268 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5269 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5270
5271 C to check gradient call subroutine check_grad
5272
5273     1 continue
5274       enddo
5275       return
5276       end
5277 #endif
5278 c------------------------------------------------------------------------------
5279       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5280 C
5281 C This procedure calculates two-body contact function g(rij) and its derivative:
5282 C
5283 C           eps0ij                                     !       x < -1
5284 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5285 C            0                                         !       x > 1
5286 C
5287 C where x=(rij-r0ij)/delta
5288 C
5289 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5290 C
5291       implicit none
5292       double precision rij,r0ij,eps0ij,fcont,fprimcont
5293       double precision x,x2,x4,delta
5294 c     delta=0.02D0*r0ij
5295 c      delta=0.2D0*r0ij
5296       x=(rij-r0ij)/delta
5297       if (x.lt.-1.0D0) then
5298         fcont=eps0ij
5299         fprimcont=0.0D0
5300       else if (x.le.1.0D0) then
5301         x2=x*x
5302         x4=x2*x2
5303         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5304         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5305       else
5306         fcont=0.0D0
5307         fprimcont=0.0D0
5308       endif
5309       return
5310       end
5311 c------------------------------------------------------------------------------
5312       subroutine splinthet(theti,delta,ss,ssder)
5313       implicit real*8 (a-h,o-z)
5314       include 'DIMENSIONS'
5315       include 'DIMENSIONS.ZSCOPT'
5316       include 'COMMON.VAR'
5317       include 'COMMON.GEO'
5318       thetup=pi-delta
5319       thetlow=delta
5320       if (theti.gt.pipol) then
5321         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5322       else
5323         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5324         ssder=-ssder
5325       endif
5326       return
5327       end
5328 c------------------------------------------------------------------------------
5329       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5330       implicit none
5331       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5332       double precision ksi,ksi2,ksi3,a1,a2,a3
5333       a1=fprim0*delta/(f1-f0)
5334       a2=3.0d0-2.0d0*a1
5335       a3=a1-2.0d0
5336       ksi=(x-x0)/delta
5337       ksi2=ksi*ksi
5338       ksi3=ksi2*ksi
5339       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5340       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5341       return
5342       end
5343 c------------------------------------------------------------------------------
5344       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5345       implicit none
5346       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5347       double precision ksi,ksi2,ksi3,a1,a2,a3
5348       ksi=(x-x0)/delta
5349       ksi2=ksi*ksi
5350       ksi3=ksi2*ksi
5351       a1=fprim0x*delta
5352       a2=3*(f1x-f0x)-2*fprim0x*delta
5353       a3=fprim0x*delta-2*(f1x-f0x)
5354       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5355       return
5356       end
5357 C-----------------------------------------------------------------------------
5358 #ifdef CRYST_TOR
5359 C-----------------------------------------------------------------------------
5360       subroutine etor(etors,edihcnstr,fact)
5361       implicit real*8 (a-h,o-z)
5362       include 'DIMENSIONS'
5363       include 'DIMENSIONS.ZSCOPT'
5364       include 'COMMON.VAR'
5365       include 'COMMON.GEO'
5366       include 'COMMON.LOCAL'
5367       include 'COMMON.TORSION'
5368       include 'COMMON.INTERACT'
5369       include 'COMMON.DERIV'
5370       include 'COMMON.CHAIN'
5371       include 'COMMON.NAMES'
5372       include 'COMMON.IOUNITS'
5373       include 'COMMON.FFIELD'
5374       include 'COMMON.TORCNSTR'
5375       logical lprn
5376 C Set lprn=.true. for debugging
5377       lprn=.false.
5378 c      lprn=.true.
5379       etors=0.0D0
5380       do i=iphi_start,iphi_end
5381         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5382      &      .or. itype(i).eq.ntyp1) cycle
5383         itori=itortyp(itype(i-2))
5384         itori1=itortyp(itype(i-1))
5385         phii=phi(i)
5386         gloci=0.0D0
5387 C Proline-Proline pair is a special case...
5388         if (itori.eq.3 .and. itori1.eq.3) then
5389           if (phii.gt.-dwapi3) then
5390             cosphi=dcos(3*phii)
5391             fac=1.0D0/(1.0D0-cosphi)
5392             etorsi=v1(1,3,3)*fac
5393             etorsi=etorsi+etorsi
5394             etors=etors+etorsi-v1(1,3,3)
5395             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5396           endif
5397           do j=1,3
5398             v1ij=v1(j+1,itori,itori1)
5399             v2ij=v2(j+1,itori,itori1)
5400             cosphi=dcos(j*phii)
5401             sinphi=dsin(j*phii)
5402             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5403             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5404           enddo
5405         else
5406           do j=1,nterm_old
5407             v1ij=v1(j,itori,itori1)
5408             v2ij=v2(j,itori,itori1)
5409             cosphi=dcos(j*phii)
5410             sinphi=dsin(j*phii)
5411             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5412             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5413           enddo
5414         endif
5415         if (lprn)
5416      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5417      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5418      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5419         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5420 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5421       enddo
5422 ! 6/20/98 - dihedral angle constraints
5423       edihcnstr=0.0d0
5424       do i=1,ndih_constr
5425         itori=idih_constr(i)
5426         phii=phi(itori)
5427         difi=phii-phi0(i)
5428         if (difi.gt.drange(i)) then
5429           difi=difi-drange(i)
5430           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5431           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5432         else if (difi.lt.-drange(i)) then
5433           difi=difi+drange(i)
5434           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5435           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5436         endif
5437 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5438 C     &    i,itori,rad2deg*phii,
5439 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5440       enddo
5441 !      write (iout,*) 'edihcnstr',edihcnstr
5442       return
5443       end
5444 c------------------------------------------------------------------------------
5445 #else
5446       subroutine etor(etors,edihcnstr,fact)
5447       implicit real*8 (a-h,o-z)
5448       include 'DIMENSIONS'
5449       include 'DIMENSIONS.ZSCOPT'
5450       include 'COMMON.VAR'
5451       include 'COMMON.GEO'
5452       include 'COMMON.LOCAL'
5453       include 'COMMON.TORSION'
5454       include 'COMMON.INTERACT'
5455       include 'COMMON.DERIV'
5456       include 'COMMON.CHAIN'
5457       include 'COMMON.NAMES'
5458       include 'COMMON.IOUNITS'
5459       include 'COMMON.FFIELD'
5460       include 'COMMON.TORCNSTR'
5461       logical lprn
5462 C Set lprn=.true. for debugging
5463       lprn=.false.
5464 c      lprn=.true.
5465       etors=0.0D0
5466       do i=iphi_start,iphi_end
5467         if (i.le.2) cycle
5468         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5469      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5470 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5471 C     &       .or. itype(i).eq.ntyp1) cycle
5472         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5473          if (iabs(itype(i)).eq.20) then
5474          iblock=2
5475          else
5476          iblock=1
5477          endif
5478         itori=itortyp(itype(i-2))
5479         itori1=itortyp(itype(i-1))
5480         phii=phi(i)
5481         gloci=0.0D0
5482 C Regular cosine and sine terms
5483         do j=1,nterm(itori,itori1,iblock)
5484           v1ij=v1(j,itori,itori1,iblock)
5485           v2ij=v2(j,itori,itori1,iblock)
5486           cosphi=dcos(j*phii)
5487           sinphi=dsin(j*phii)
5488           etors=etors+v1ij*cosphi+v2ij*sinphi
5489           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5490         enddo
5491 C Lorentz terms
5492 C                         v1
5493 C  E = SUM ----------------------------------- - v1
5494 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5495 C
5496         cosphi=dcos(0.5d0*phii)
5497         sinphi=dsin(0.5d0*phii)
5498         do j=1,nlor(itori,itori1,iblock)
5499           vl1ij=vlor1(j,itori,itori1)
5500           vl2ij=vlor2(j,itori,itori1)
5501           vl3ij=vlor3(j,itori,itori1)
5502           pom=vl2ij*cosphi+vl3ij*sinphi
5503           pom1=1.0d0/(pom*pom+1.0d0)
5504           etors=etors+vl1ij*pom1
5505 c          if (energy_dec) etors_ii=etors_ii+
5506 c     &                vl1ij*pom1
5507           pom=-pom*pom1*pom1
5508           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5509         enddo
5510 C Subtract the constant term
5511         etors=etors-v0(itori,itori1,iblock)
5512         if (lprn)
5513      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5514      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5515      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5516         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5517 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5518  1215   continue
5519       enddo
5520 ! 6/20/98 - dihedral angle constraints
5521       edihcnstr=0.0d0
5522       do i=1,ndih_constr
5523         itori=idih_constr(i)
5524         phii=phi(itori)
5525         difi=pinorm(phii-phi0(i))
5526         edihi=0.0d0
5527         if (difi.gt.drange(i)) then
5528           difi=difi-drange(i)
5529           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5530           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5531           edihi=0.25d0*ftors(i)*difi**4
5532         else if (difi.lt.-drange(i)) then
5533           difi=difi+drange(i)
5534           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5535           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5536           edihi=0.25d0*ftors(i)*difi**4
5537         else
5538           difi=0.0d0
5539         endif
5540         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5541      &    i,itori,rad2deg*phii,
5542      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5543 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5544 c     &    drange(i),edihi
5545 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5546 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5547       enddo
5548 !      write (iout,*) 'edihcnstr',edihcnstr
5549       return
5550       end
5551 c----------------------------------------------------------------------------
5552       subroutine etor_d(etors_d,fact2)
5553 C 6/23/01 Compute double torsional energy
5554       implicit real*8 (a-h,o-z)
5555       include 'DIMENSIONS'
5556       include 'DIMENSIONS.ZSCOPT'
5557       include 'COMMON.VAR'
5558       include 'COMMON.GEO'
5559       include 'COMMON.LOCAL'
5560       include 'COMMON.TORSION'
5561       include 'COMMON.INTERACT'
5562       include 'COMMON.DERIV'
5563       include 'COMMON.CHAIN'
5564       include 'COMMON.NAMES'
5565       include 'COMMON.IOUNITS'
5566       include 'COMMON.FFIELD'
5567       include 'COMMON.TORCNSTR'
5568       logical lprn
5569 C Set lprn=.true. for debugging
5570       lprn=.false.
5571 c     lprn=.true.
5572       etors_d=0.0D0
5573       do i=iphi_start,iphi_end-1
5574         if (i.le.3) cycle
5575 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5576 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5577          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5578      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5579      &  (itype(i+1).eq.ntyp1)) cycle
5580         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5581      &     goto 1215
5582         itori=itortyp(itype(i-2))
5583         itori1=itortyp(itype(i-1))
5584         itori2=itortyp(itype(i))
5585         phii=phi(i)
5586         phii1=phi(i+1)
5587         gloci1=0.0D0
5588         gloci2=0.0D0
5589         iblock=1
5590         if (iabs(itype(i+1)).eq.20) iblock=2
5591 C Regular cosine and sine terms
5592         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5593           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5594           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5595           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5596           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5597           cosphi1=dcos(j*phii)
5598           sinphi1=dsin(j*phii)
5599           cosphi2=dcos(j*phii1)
5600           sinphi2=dsin(j*phii1)
5601           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5602      &     v2cij*cosphi2+v2sij*sinphi2
5603           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5604           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5605         enddo
5606         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5607           do l=1,k-1
5608             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5609             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5610             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5611             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5612             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5613             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5614             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5615             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5616             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5617      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5618             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5619      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5620             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5621      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5622           enddo
5623         enddo
5624         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5625         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5626  1215   continue
5627       enddo
5628       return
5629       end
5630 #endif
5631 c------------------------------------------------------------------------------
5632       subroutine eback_sc_corr(esccor)
5633 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5634 c        conformational states; temporarily implemented as differences
5635 c        between UNRES torsional potentials (dependent on three types of
5636 c        residues) and the torsional potentials dependent on all 20 types
5637 c        of residues computed from AM1 energy surfaces of terminally-blocked
5638 c        amino-acid residues.
5639       implicit real*8 (a-h,o-z)
5640       include 'DIMENSIONS'
5641       include 'DIMENSIONS.ZSCOPT'
5642       include 'COMMON.VAR'
5643       include 'COMMON.GEO'
5644       include 'COMMON.LOCAL'
5645       include 'COMMON.TORSION'
5646       include 'COMMON.SCCOR'
5647       include 'COMMON.INTERACT'
5648       include 'COMMON.DERIV'
5649       include 'COMMON.CHAIN'
5650       include 'COMMON.NAMES'
5651       include 'COMMON.IOUNITS'
5652       include 'COMMON.FFIELD'
5653       include 'COMMON.CONTROL'
5654       logical lprn
5655 C Set lprn=.true. for debugging
5656       lprn=.false.
5657 c      lprn=.true.
5658 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5659       esccor=0.0D0
5660       do i=itau_start,itau_end
5661         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5662         esccor_ii=0.0D0
5663         isccori=isccortyp(itype(i-2))
5664         isccori1=isccortyp(itype(i-1))
5665         phii=phi(i)
5666         do intertyp=1,3 !intertyp
5667 cc Added 09 May 2012 (Adasko)
5668 cc  Intertyp means interaction type of backbone mainchain correlation:
5669 c   1 = SC...Ca...Ca...Ca
5670 c   2 = Ca...Ca...Ca...SC
5671 c   3 = SC...Ca...Ca...SCi
5672         gloci=0.0D0
5673         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5674      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5675      &      (itype(i-1).eq.ntyp1)))
5676      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5677      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5678      &     .or.(itype(i).eq.ntyp1)))
5679      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5680      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5681      &      (itype(i-3).eq.ntyp1)))) cycle
5682         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5683         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5684      & cycle
5685        do j=1,nterm_sccor(isccori,isccori1)
5686           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5687           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5688           cosphi=dcos(j*tauangle(intertyp,i))
5689           sinphi=dsin(j*tauangle(intertyp,i))
5690            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5691            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5692          enddo
5693 C      write (iout,*)"EBACK_SC_COR",esccor,i
5694 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5695 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5696 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5697         if (lprn)
5698      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5699      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5700      &  (v1sccor(j,1,itori,itori1),j=1,6)
5701      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5702 c        gsccor_loc(i-3)=gloci
5703        enddo !intertyp
5704       enddo
5705       return
5706       end
5707 c------------------------------------------------------------------------------
5708       subroutine multibody(ecorr)
5709 C This subroutine calculates multi-body contributions to energy following
5710 C the idea of Skolnick et al. If side chains I and J make a contact and
5711 C at the same time side chains I+1 and J+1 make a contact, an extra
5712 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5713       implicit real*8 (a-h,o-z)
5714       include 'DIMENSIONS'
5715       include 'COMMON.IOUNITS'
5716       include 'COMMON.DERIV'
5717       include 'COMMON.INTERACT'
5718       include 'COMMON.CONTACTS'
5719       double precision gx(3),gx1(3)
5720       logical lprn
5721
5722 C Set lprn=.true. for debugging
5723       lprn=.false.
5724
5725       if (lprn) then
5726         write (iout,'(a)') 'Contact function values:'
5727         do i=nnt,nct-2
5728           write (iout,'(i2,20(1x,i2,f10.5))')
5729      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5730         enddo
5731       endif
5732       ecorr=0.0D0
5733       do i=nnt,nct
5734         do j=1,3
5735           gradcorr(j,i)=0.0D0
5736           gradxorr(j,i)=0.0D0
5737         enddo
5738       enddo
5739       do i=nnt,nct-2
5740
5741         DO ISHIFT = 3,4
5742
5743         i1=i+ishift
5744         num_conti=num_cont(i)
5745         num_conti1=num_cont(i1)
5746         do jj=1,num_conti
5747           j=jcont(jj,i)
5748           do kk=1,num_conti1
5749             j1=jcont(kk,i1)
5750             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5751 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5752 cd   &                   ' ishift=',ishift
5753 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5754 C The system gains extra energy.
5755               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5756             endif   ! j1==j+-ishift
5757           enddo     ! kk
5758         enddo       ! jj
5759
5760         ENDDO ! ISHIFT
5761
5762       enddo         ! i
5763       return
5764       end
5765 c------------------------------------------------------------------------------
5766       double precision function esccorr(i,j,k,l,jj,kk)
5767       implicit real*8 (a-h,o-z)
5768       include 'DIMENSIONS'
5769       include 'COMMON.IOUNITS'
5770       include 'COMMON.DERIV'
5771       include 'COMMON.INTERACT'
5772       include 'COMMON.CONTACTS'
5773       double precision gx(3),gx1(3)
5774       logical lprn
5775       lprn=.false.
5776       eij=facont(jj,i)
5777       ekl=facont(kk,k)
5778 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5779 C Calculate the multi-body contribution to energy.
5780 C Calculate multi-body contributions to the gradient.
5781 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5782 cd   & k,l,(gacont(m,kk,k),m=1,3)
5783       do m=1,3
5784         gx(m) =ekl*gacont(m,jj,i)
5785         gx1(m)=eij*gacont(m,kk,k)
5786         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5787         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5788         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5789         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5790       enddo
5791       do m=i,j-1
5792         do ll=1,3
5793           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5794         enddo
5795       enddo
5796       do m=k,l-1
5797         do ll=1,3
5798           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5799         enddo
5800       enddo
5801       esccorr=-eij*ekl
5802       return
5803       end
5804 c------------------------------------------------------------------------------
5805 #ifdef MPL
5806       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5807       implicit real*8 (a-h,o-z)
5808       include 'DIMENSIONS'
5809       integer dimen1,dimen2,atom,indx
5810       double precision buffer(dimen1,dimen2)
5811       double precision zapas
5812       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5813      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5814      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5815       num_kont=num_cont_hb(atom)
5816       do i=1,num_kont
5817         do k=1,7
5818           do j=1,3
5819             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5820           enddo ! j
5821         enddo ! k
5822         buffer(i,indx+22)=facont_hb(i,atom)
5823         buffer(i,indx+23)=ees0p(i,atom)
5824         buffer(i,indx+24)=ees0m(i,atom)
5825         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5826       enddo ! i
5827       buffer(1,indx+26)=dfloat(num_kont)
5828       return
5829       end
5830 c------------------------------------------------------------------------------
5831       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5832       implicit real*8 (a-h,o-z)
5833       include 'DIMENSIONS'
5834       integer dimen1,dimen2,atom,indx
5835       double precision buffer(dimen1,dimen2)
5836       double precision zapas
5837       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5838      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5839      &         ees0m(ntyp,maxres),
5840      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5841       num_kont=buffer(1,indx+26)
5842       num_kont_old=num_cont_hb(atom)
5843       num_cont_hb(atom)=num_kont+num_kont_old
5844       do i=1,num_kont
5845         ii=i+num_kont_old
5846         do k=1,7
5847           do j=1,3
5848             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5849           enddo ! j
5850         enddo ! k
5851         facont_hb(ii,atom)=buffer(i,indx+22)
5852         ees0p(ii,atom)=buffer(i,indx+23)
5853         ees0m(ii,atom)=buffer(i,indx+24)
5854         jcont_hb(ii,atom)=buffer(i,indx+25)
5855       enddo ! i
5856       return
5857       end
5858 c------------------------------------------------------------------------------
5859 #endif
5860       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5861 C This subroutine calculates multi-body contributions to hydrogen-bonding
5862       implicit real*8 (a-h,o-z)
5863       include 'DIMENSIONS'
5864       include 'DIMENSIONS.ZSCOPT'
5865       include 'COMMON.IOUNITS'
5866 #ifdef MPL
5867       include 'COMMON.INFO'
5868 #endif
5869       include 'COMMON.FFIELD'
5870       include 'COMMON.DERIV'
5871       include 'COMMON.INTERACT'
5872       include 'COMMON.CONTACTS'
5873 #ifdef MPL
5874       parameter (max_cont=maxconts)
5875       parameter (max_dim=2*(8*3+2))
5876       parameter (msglen1=max_cont*max_dim*4)
5877       parameter (msglen2=2*msglen1)
5878       integer source,CorrelType,CorrelID,Error
5879       double precision buffer(max_cont,max_dim)
5880 #endif
5881       double precision gx(3),gx1(3)
5882       logical lprn,ldone
5883
5884 C Set lprn=.true. for debugging
5885       lprn=.false.
5886 #ifdef MPL
5887       n_corr=0
5888       n_corr1=0
5889       if (fgProcs.le.1) goto 30
5890       if (lprn) then
5891         write (iout,'(a)') 'Contact function values:'
5892         do i=nnt,nct-2
5893           write (iout,'(2i3,50(1x,i2,f5.2))')
5894      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5895      &    j=1,num_cont_hb(i))
5896         enddo
5897       endif
5898 C Caution! Following code assumes that electrostatic interactions concerning
5899 C a given atom are split among at most two processors!
5900       CorrelType=477
5901       CorrelID=MyID+1
5902       ldone=.false.
5903       do i=1,max_cont
5904         do j=1,max_dim
5905           buffer(i,j)=0.0D0
5906         enddo
5907       enddo
5908       mm=mod(MyRank,2)
5909 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5910       if (mm) 20,20,10
5911    10 continue
5912 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5913       if (MyRank.gt.0) then
5914 C Send correlation contributions to the preceding processor
5915         msglen=msglen1
5916         nn=num_cont_hb(iatel_s)
5917         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5918 cd      write (iout,*) 'The BUFFER array:'
5919 cd      do i=1,nn
5920 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5921 cd      enddo
5922         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5923           msglen=msglen2
5924             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5925 C Clear the contacts of the atom passed to the neighboring processor
5926         nn=num_cont_hb(iatel_s+1)
5927 cd      do i=1,nn
5928 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5929 cd      enddo
5930             num_cont_hb(iatel_s)=0
5931         endif
5932 cd      write (iout,*) 'Processor ',MyID,MyRank,
5933 cd   & ' is sending correlation contribution to processor',MyID-1,
5934 cd   & ' msglen=',msglen
5935 cd      write (*,*) 'Processor ',MyID,MyRank,
5936 cd   & ' is sending correlation contribution to processor',MyID-1,
5937 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5938         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5939 cd      write (iout,*) 'Processor ',MyID,
5940 cd   & ' has sent correlation contribution to processor',MyID-1,
5941 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5942 cd      write (*,*) 'Processor ',MyID,
5943 cd   & ' has sent correlation contribution to processor',MyID-1,
5944 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5945         msglen=msglen1
5946       endif ! (MyRank.gt.0)
5947       if (ldone) goto 30
5948       ldone=.true.
5949    20 continue
5950 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5951       if (MyRank.lt.fgProcs-1) then
5952 C Receive correlation contributions from the next processor
5953         msglen=msglen1
5954         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5955 cd      write (iout,*) 'Processor',MyID,
5956 cd   & ' is receiving correlation contribution from processor',MyID+1,
5957 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5958 cd      write (*,*) 'Processor',MyID,
5959 cd   & ' is receiving correlation contribution from processor',MyID+1,
5960 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5961         nbytes=-1
5962         do while (nbytes.le.0)
5963           call mp_probe(MyID+1,CorrelType,nbytes)
5964         enddo
5965 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5966         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5967 cd      write (iout,*) 'Processor',MyID,
5968 cd   & ' has received correlation contribution from processor',MyID+1,
5969 cd   & ' msglen=',msglen,' nbytes=',nbytes
5970 cd      write (iout,*) 'The received BUFFER array:'
5971 cd      do i=1,max_cont
5972 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5973 cd      enddo
5974         if (msglen.eq.msglen1) then
5975           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5976         else if (msglen.eq.msglen2)  then
5977           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5978           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5979         else
5980           write (iout,*)
5981      & 'ERROR!!!! message length changed while processing correlations.'
5982           write (*,*)
5983      & 'ERROR!!!! message length changed while processing correlations.'
5984           call mp_stopall(Error)
5985         endif ! msglen.eq.msglen1
5986       endif ! MyRank.lt.fgProcs-1
5987       if (ldone) goto 30
5988       ldone=.true.
5989       goto 10
5990    30 continue
5991 #endif
5992       if (lprn) then
5993         write (iout,'(a)') 'Contact function values:'
5994         do i=nnt,nct-2
5995           write (iout,'(2i3,50(1x,i2,f5.2))')
5996      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5997      &    j=1,num_cont_hb(i))
5998         enddo
5999       endif
6000       ecorr=0.0D0
6001 C Remove the loop below after debugging !!!
6002       do i=nnt,nct
6003         do j=1,3
6004           gradcorr(j,i)=0.0D0
6005           gradxorr(j,i)=0.0D0
6006         enddo
6007       enddo
6008 C Calculate the local-electrostatic correlation terms
6009       do i=iatel_s,iatel_e+1
6010         i1=i+1
6011         num_conti=num_cont_hb(i)
6012         num_conti1=num_cont_hb(i+1)
6013         do jj=1,num_conti
6014           j=jcont_hb(jj,i)
6015           do kk=1,num_conti1
6016             j1=jcont_hb(kk,i1)
6017 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6018 c     &         ' jj=',jj,' kk=',kk
6019             if (j1.eq.j+1 .or. j1.eq.j-1) then
6020 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6021 C The system gains extra energy.
6022               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6023               n_corr=n_corr+1
6024             else if (j1.eq.j) then
6025 C Contacts I-J and I-(J+1) occur simultaneously.
6026 C The system loses extra energy.
6027 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6028             endif
6029           enddo ! kk
6030           do kk=1,num_conti
6031             j1=jcont_hb(kk,i)
6032 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6033 c    &         ' jj=',jj,' kk=',kk
6034             if (j1.eq.j+1) then
6035 C Contacts I-J and (I+1)-J occur simultaneously.
6036 C The system loses extra energy.
6037 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6038             endif ! j1==j+1
6039           enddo ! kk
6040         enddo ! jj
6041       enddo ! i
6042       return
6043       end
6044 c------------------------------------------------------------------------------
6045       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6046      &  n_corr1)
6047 C This subroutine calculates multi-body contributions to hydrogen-bonding
6048       implicit real*8 (a-h,o-z)
6049       include 'DIMENSIONS'
6050       include 'DIMENSIONS.ZSCOPT'
6051       include 'COMMON.IOUNITS'
6052 #ifdef MPL
6053       include 'COMMON.INFO'
6054 #endif
6055       include 'COMMON.FFIELD'
6056       include 'COMMON.DERIV'
6057       include 'COMMON.INTERACT'
6058       include 'COMMON.CONTACTS'
6059 #ifdef MPL
6060       parameter (max_cont=maxconts)
6061       parameter (max_dim=2*(8*3+2))
6062       parameter (msglen1=max_cont*max_dim*4)
6063       parameter (msglen2=2*msglen1)
6064       integer source,CorrelType,CorrelID,Error
6065       double precision buffer(max_cont,max_dim)
6066 #endif
6067       double precision gx(3),gx1(3)
6068       logical lprn,ldone
6069
6070 C Set lprn=.true. for debugging
6071       lprn=.false.
6072       eturn6=0.0d0
6073       ecorr6=0.0d0
6074 #ifdef MPL
6075       n_corr=0
6076       n_corr1=0
6077       if (fgProcs.le.1) goto 30
6078       if (lprn) then
6079         write (iout,'(a)') 'Contact function values:'
6080         do i=nnt,nct-2
6081           write (iout,'(2i3,50(1x,i2,f5.2))')
6082      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6083      &    j=1,num_cont_hb(i))
6084         enddo
6085       endif
6086 C Caution! Following code assumes that electrostatic interactions concerning
6087 C a given atom are split among at most two processors!
6088       CorrelType=477
6089       CorrelID=MyID+1
6090       ldone=.false.
6091       do i=1,max_cont
6092         do j=1,max_dim
6093           buffer(i,j)=0.0D0
6094         enddo
6095       enddo
6096       mm=mod(MyRank,2)
6097 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6098       if (mm) 20,20,10
6099    10 continue
6100 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6101       if (MyRank.gt.0) then
6102 C Send correlation contributions to the preceding processor
6103         msglen=msglen1
6104         nn=num_cont_hb(iatel_s)
6105         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6106 cd      write (iout,*) 'The BUFFER array:'
6107 cd      do i=1,nn
6108 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6109 cd      enddo
6110         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6111           msglen=msglen2
6112             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6113 C Clear the contacts of the atom passed to the neighboring processor
6114         nn=num_cont_hb(iatel_s+1)
6115 cd      do i=1,nn
6116 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6117 cd      enddo
6118             num_cont_hb(iatel_s)=0
6119         endif
6120 cd      write (iout,*) 'Processor ',MyID,MyRank,
6121 cd   & ' is sending correlation contribution to processor',MyID-1,
6122 cd   & ' msglen=',msglen
6123 cd      write (*,*) 'Processor ',MyID,MyRank,
6124 cd   & ' is sending correlation contribution to processor',MyID-1,
6125 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6126         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6127 cd      write (iout,*) 'Processor ',MyID,
6128 cd   & ' has sent correlation contribution to processor',MyID-1,
6129 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6130 cd      write (*,*) 'Processor ',MyID,
6131 cd   & ' has sent correlation contribution to processor',MyID-1,
6132 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6133         msglen=msglen1
6134       endif ! (MyRank.gt.0)
6135       if (ldone) goto 30
6136       ldone=.true.
6137    20 continue
6138 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6139       if (MyRank.lt.fgProcs-1) then
6140 C Receive correlation contributions from the next processor
6141         msglen=msglen1
6142         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6143 cd      write (iout,*) 'Processor',MyID,
6144 cd   & ' is receiving correlation contribution from processor',MyID+1,
6145 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6146 cd      write (*,*) 'Processor',MyID,
6147 cd   & ' is receiving correlation contribution from processor',MyID+1,
6148 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6149         nbytes=-1
6150         do while (nbytes.le.0)
6151           call mp_probe(MyID+1,CorrelType,nbytes)
6152         enddo
6153 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6154         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6155 cd      write (iout,*) 'Processor',MyID,
6156 cd   & ' has received correlation contribution from processor',MyID+1,
6157 cd   & ' msglen=',msglen,' nbytes=',nbytes
6158 cd      write (iout,*) 'The received BUFFER array:'
6159 cd      do i=1,max_cont
6160 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6161 cd      enddo
6162         if (msglen.eq.msglen1) then
6163           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6164         else if (msglen.eq.msglen2)  then
6165           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6166           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6167         else
6168           write (iout,*)
6169      & 'ERROR!!!! message length changed while processing correlations.'
6170           write (*,*)
6171      & 'ERROR!!!! message length changed while processing correlations.'
6172           call mp_stopall(Error)
6173         endif ! msglen.eq.msglen1
6174       endif ! MyRank.lt.fgProcs-1
6175       if (ldone) goto 30
6176       ldone=.true.
6177       goto 10
6178    30 continue
6179 #endif
6180       if (lprn) then
6181         write (iout,'(a)') 'Contact function values:'
6182         do i=nnt,nct-2
6183           write (iout,'(2i3,50(1x,i2,f5.2))')
6184      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6185      &    j=1,num_cont_hb(i))
6186         enddo
6187       endif
6188       ecorr=0.0D0
6189       ecorr5=0.0d0
6190       ecorr6=0.0d0
6191 C Remove the loop below after debugging !!!
6192       do i=nnt,nct
6193         do j=1,3
6194           gradcorr(j,i)=0.0D0
6195           gradxorr(j,i)=0.0D0
6196         enddo
6197       enddo
6198 C Calculate the dipole-dipole interaction energies
6199       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6200       do i=iatel_s,iatel_e+1
6201         num_conti=num_cont_hb(i)
6202         do jj=1,num_conti
6203           j=jcont_hb(jj,i)
6204           call dipole(i,j,jj)
6205         enddo
6206       enddo
6207       endif
6208 C Calculate the local-electrostatic correlation terms
6209       do i=iatel_s,iatel_e+1
6210         i1=i+1
6211         num_conti=num_cont_hb(i)
6212         num_conti1=num_cont_hb(i+1)
6213         do jj=1,num_conti
6214           j=jcont_hb(jj,i)
6215           do kk=1,num_conti1
6216             j1=jcont_hb(kk,i1)
6217 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6218 c     &         ' jj=',jj,' kk=',kk
6219             if (j1.eq.j+1 .or. j1.eq.j-1) then
6220 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6221 C The system gains extra energy.
6222               n_corr=n_corr+1
6223               sqd1=dsqrt(d_cont(jj,i))
6224               sqd2=dsqrt(d_cont(kk,i1))
6225               sred_geom = sqd1*sqd2
6226               IF (sred_geom.lt.cutoff_corr) THEN
6227                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6228      &            ekont,fprimcont)
6229 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6230 c     &         ' jj=',jj,' kk=',kk
6231                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6232                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6233                 do l=1,3
6234                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6235                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6236                 enddo
6237                 n_corr1=n_corr1+1
6238 cd               write (iout,*) 'sred_geom=',sred_geom,
6239 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6240                 call calc_eello(i,j,i+1,j1,jj,kk)
6241                 if (wcorr4.gt.0.0d0)
6242      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6243                 if (wcorr5.gt.0.0d0)
6244      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6245 c                print *,"wcorr5",ecorr5
6246 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6247 cd                write(2,*)'ijkl',i,j,i+1,j1
6248                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6249      &               .or. wturn6.eq.0.0d0))then
6250 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6251                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6252 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6253 cd     &            'ecorr6=',ecorr6
6254 cd                write (iout,'(4e15.5)') sred_geom,
6255 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6256 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6257 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6258                 else if (wturn6.gt.0.0d0
6259      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6260 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6261                   eturn6=eturn6+eello_turn6(i,jj,kk)
6262 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6263                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6264                    eturn6=0.0d0
6265                    ecorr6=0.0d0
6266                 endif
6267
6268               ENDIF
6269 1111          continue
6270             else if (j1.eq.j) then
6271 C Contacts I-J and I-(J+1) occur simultaneously.
6272 C The system loses extra energy.
6273 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6274             endif
6275           enddo ! kk
6276           do kk=1,num_conti
6277             j1=jcont_hb(kk,i)
6278 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6279 c    &         ' jj=',jj,' kk=',kk
6280             if (j1.eq.j+1) then
6281 C Contacts I-J and (I+1)-J occur simultaneously.
6282 C The system loses extra energy.
6283 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6284             endif ! j1==j+1
6285           enddo ! kk
6286         enddo ! jj
6287       enddo ! i
6288       write (iout,*) "eturn6",eturn6,ecorr6
6289       return
6290       end
6291 c------------------------------------------------------------------------------
6292       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6293       implicit real*8 (a-h,o-z)
6294       include 'DIMENSIONS'
6295       include 'COMMON.IOUNITS'
6296       include 'COMMON.DERIV'
6297       include 'COMMON.INTERACT'
6298       include 'COMMON.CONTACTS'
6299       include 'COMMON.CONTROL'
6300       include 'COMMON.SHIELD'
6301       double precision gx(3),gx1(3)
6302       logical lprn
6303       lprn=.false.
6304       eij=facont_hb(jj,i)
6305       ekl=facont_hb(kk,k)
6306       ees0pij=ees0p(jj,i)
6307       ees0pkl=ees0p(kk,k)
6308       ees0mij=ees0m(jj,i)
6309       ees0mkl=ees0m(kk,k)
6310       ekont=eij*ekl
6311       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6312 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6313 C Following 4 lines for diagnostics.
6314 cd    ees0pkl=0.0D0
6315 cd    ees0pij=1.0D0
6316 cd    ees0mkl=0.0D0
6317 cd    ees0mij=1.0D0
6318 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6319 c    &   ' and',k,l
6320 c     write (iout,*)'Contacts have occurred for peptide groups',
6321 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6322 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6323 C Calculate the multi-body contribution to energy.
6324 C      ecorr=ecorr+ekont*ees
6325       if (calc_grad) then
6326 C Calculate multi-body contributions to the gradient.
6327       do ll=1,3
6328         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6329         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6330      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6331      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6332         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6333      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6334      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6335         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6336         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6337      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6338      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6339         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6340      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6341      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6342       enddo
6343       do m=i+1,j-1
6344         do ll=1,3
6345           gradcorr(ll,m)=gradcorr(ll,m)+
6346      &     ees*ekl*gacont_hbr(ll,jj,i)-
6347      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6348      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6349         enddo
6350       enddo
6351       do m=k+1,l-1
6352         do ll=1,3
6353           gradcorr(ll,m)=gradcorr(ll,m)+
6354      &     ees*eij*gacont_hbr(ll,kk,k)-
6355      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6356      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6357         enddo
6358       enddo
6359       if (shield_mode.gt.0) then
6360        j=ees0plist(jj,i)
6361        l=ees0plist(kk,k)
6362 C        print *,i,j,fac_shield(i),fac_shield(j),
6363 C     &fac_shield(k),fac_shield(l)
6364         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6365      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6366           do ilist=1,ishield_list(i)
6367            iresshield=shield_list(ilist,i)
6368            do m=1,3
6369            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6370 C     &      *2.0
6371            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6372      &              rlocshield
6373      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6374             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6375      &+rlocshield
6376            enddo
6377           enddo
6378           do ilist=1,ishield_list(j)
6379            iresshield=shield_list(ilist,j)
6380            do m=1,3
6381            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6382 C     &     *2.0
6383            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6384      &              rlocshield
6385      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6386            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6387      &     +rlocshield
6388            enddo
6389           enddo
6390           do ilist=1,ishield_list(k)
6391            iresshield=shield_list(ilist,k)
6392            do m=1,3
6393            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6394 C     &     *2.0
6395            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6396      &              rlocshield
6397      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6398            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6399      &     +rlocshield
6400            enddo
6401           enddo
6402           do ilist=1,ishield_list(l)
6403            iresshield=shield_list(ilist,l)
6404            do m=1,3
6405            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6406 C     &     *2.0
6407            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6408      &              rlocshield
6409      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6410            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6411      &     +rlocshield
6412            enddo
6413           enddo
6414 C          print *,gshieldx(m,iresshield)
6415           do m=1,3
6416             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6417      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6418             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6419      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6420             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6421      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6422             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6423      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6424
6425             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6426      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6427             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6428      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6429             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6430      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6431             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6432      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6433
6434            enddo
6435       endif
6436       endif
6437       endif
6438       ehbcorr=ekont*ees
6439       return
6440       end
6441 C---------------------------------------------------------------------------
6442       subroutine dipole(i,j,jj)
6443       implicit real*8 (a-h,o-z)
6444       include 'DIMENSIONS'
6445       include 'DIMENSIONS.ZSCOPT'
6446       include 'COMMON.IOUNITS'
6447       include 'COMMON.CHAIN'
6448       include 'COMMON.FFIELD'
6449       include 'COMMON.DERIV'
6450       include 'COMMON.INTERACT'
6451       include 'COMMON.CONTACTS'
6452       include 'COMMON.TORSION'
6453       include 'COMMON.VAR'
6454       include 'COMMON.GEO'
6455       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6456      &  auxmat(2,2)
6457       iti1 = itortyp(itype(i+1))
6458       if (j.lt.nres-1) then
6459         if (itype(j).le.ntyp) then
6460           itj1 = itortyp(itype(j+1))
6461         else
6462           itj=ntortyp+1
6463         endif
6464       else
6465         itj1=ntortyp+1
6466       endif
6467       do iii=1,2
6468         dipi(iii,1)=Ub2(iii,i)
6469         dipderi(iii)=Ub2der(iii,i)
6470         dipi(iii,2)=b1(iii,iti1)
6471         dipj(iii,1)=Ub2(iii,j)
6472         dipderj(iii)=Ub2der(iii,j)
6473         dipj(iii,2)=b1(iii,itj1)
6474       enddo
6475       kkk=0
6476       do iii=1,2
6477         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6478         do jjj=1,2
6479           kkk=kkk+1
6480           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6481         enddo
6482       enddo
6483       if (.not.calc_grad) return
6484       do kkk=1,5
6485         do lll=1,3
6486           mmm=0
6487           do iii=1,2
6488             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6489      &        auxvec(1))
6490             do jjj=1,2
6491               mmm=mmm+1
6492               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6493             enddo
6494           enddo
6495         enddo
6496       enddo
6497       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6498       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6499       do iii=1,2
6500         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6501       enddo
6502       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6503       do iii=1,2
6504         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6505       enddo
6506       return
6507       end
6508 C---------------------------------------------------------------------------
6509       subroutine calc_eello(i,j,k,l,jj,kk)
6510 C
6511 C This subroutine computes matrices and vectors needed to calculate
6512 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6513 C
6514       implicit real*8 (a-h,o-z)
6515       include 'DIMENSIONS'
6516       include 'DIMENSIONS.ZSCOPT'
6517       include 'COMMON.IOUNITS'
6518       include 'COMMON.CHAIN'
6519       include 'COMMON.DERIV'
6520       include 'COMMON.INTERACT'
6521       include 'COMMON.CONTACTS'
6522       include 'COMMON.TORSION'
6523       include 'COMMON.VAR'
6524       include 'COMMON.GEO'
6525       include 'COMMON.FFIELD'
6526       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6527      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6528       logical lprn
6529       common /kutas/ lprn
6530 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6531 cd     & ' jj=',jj,' kk=',kk
6532 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6533       do iii=1,2
6534         do jjj=1,2
6535           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6536           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6537         enddo
6538       enddo
6539       call transpose2(aa1(1,1),aa1t(1,1))
6540       call transpose2(aa2(1,1),aa2t(1,1))
6541       do kkk=1,5
6542         do lll=1,3
6543           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6544      &      aa1tder(1,1,lll,kkk))
6545           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6546      &      aa2tder(1,1,lll,kkk))
6547         enddo
6548       enddo
6549       if (l.eq.j+1) then
6550 C parallel orientation of the two CA-CA-CA frames.
6551         if (i.gt.1 .and. itype(i).le.ntyp) then
6552           iti=itortyp(itype(i))
6553         else
6554           iti=ntortyp+1
6555         endif
6556         itk1=itortyp(itype(k+1))
6557         itj=itortyp(itype(j))
6558         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6559           itl1=itortyp(itype(l+1))
6560         else
6561           itl1=ntortyp+1
6562         endif
6563 C A1 kernel(j+1) A2T
6564 cd        do iii=1,2
6565 cd          write (iout,'(3f10.5,5x,3f10.5)')
6566 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6567 cd        enddo
6568         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6569      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6570      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6571 C Following matrices are needed only for 6-th order cumulants
6572         IF (wcorr6.gt.0.0d0) THEN
6573         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6574      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6575      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6576         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6577      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6578      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6579      &   ADtEAderx(1,1,1,1,1,1))
6580         lprn=.false.
6581         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6582      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6583      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6584      &   ADtEA1derx(1,1,1,1,1,1))
6585         ENDIF
6586 C End 6-th order cumulants
6587 cd        lprn=.false.
6588 cd        if (lprn) then
6589 cd        write (2,*) 'In calc_eello6'
6590 cd        do iii=1,2
6591 cd          write (2,*) 'iii=',iii
6592 cd          do kkk=1,5
6593 cd            write (2,*) 'kkk=',kkk
6594 cd            do jjj=1,2
6595 cd              write (2,'(3(2f10.5),5x)')
6596 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6597 cd            enddo
6598 cd          enddo
6599 cd        enddo
6600 cd        endif
6601         call transpose2(EUgder(1,1,k),auxmat(1,1))
6602         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6603         call transpose2(EUg(1,1,k),auxmat(1,1))
6604         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6605         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
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,1),
6610      &          EAEAderx(1,1,lll,kkk,iii,1))
6611             enddo
6612           enddo
6613         enddo
6614 C A1T kernel(i+1) A2
6615         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6616      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6617      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6618 C Following matrices are needed only for 6-th order cumulants
6619         IF (wcorr6.gt.0.0d0) THEN
6620         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6621      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6622      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6623         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6624      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6625      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6626      &   ADtEAderx(1,1,1,1,1,2))
6627         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6628      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6629      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6630      &   ADtEA1derx(1,1,1,1,1,2))
6631         ENDIF
6632 C End 6-th order cumulants
6633         call transpose2(EUgder(1,1,l),auxmat(1,1))
6634         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6635         call transpose2(EUg(1,1,l),auxmat(1,1))
6636         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6637         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6638         do iii=1,2
6639           do kkk=1,5
6640             do lll=1,3
6641               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6642      &          EAEAderx(1,1,lll,kkk,iii,2))
6643             enddo
6644           enddo
6645         enddo
6646 C AEAb1 and AEAb2
6647 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6648 C They are needed only when the fifth- or the sixth-order cumulants are
6649 C indluded.
6650         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6651         call transpose2(AEA(1,1,1),auxmat(1,1))
6652         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6653         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6654         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6655         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6656         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6657         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6658         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6659         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6660         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6661         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6662         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6663         call transpose2(AEA(1,1,2),auxmat(1,1))
6664         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6665         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6666         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6667         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6668         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6669         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6670         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6671         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6672         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6673         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6674         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6675 C Calculate the Cartesian derivatives of the vectors.
6676         do iii=1,2
6677           do kkk=1,5
6678             do lll=1,3
6679               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6680               call matvec2(auxmat(1,1),b1(1,iti),
6681      &          AEAb1derx(1,lll,kkk,iii,1,1))
6682               call matvec2(auxmat(1,1),Ub2(1,i),
6683      &          AEAb2derx(1,lll,kkk,iii,1,1))
6684               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6685      &          AEAb1derx(1,lll,kkk,iii,2,1))
6686               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6687      &          AEAb2derx(1,lll,kkk,iii,2,1))
6688               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6689               call matvec2(auxmat(1,1),b1(1,itj),
6690      &          AEAb1derx(1,lll,kkk,iii,1,2))
6691               call matvec2(auxmat(1,1),Ub2(1,j),
6692      &          AEAb2derx(1,lll,kkk,iii,1,2))
6693               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6694      &          AEAb1derx(1,lll,kkk,iii,2,2))
6695               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6696      &          AEAb2derx(1,lll,kkk,iii,2,2))
6697             enddo
6698           enddo
6699         enddo
6700         ENDIF
6701 C End vectors
6702       else
6703 C Antiparallel orientation of the two CA-CA-CA frames.
6704         if (i.gt.1 .and. itype(i).le.ntyp) then
6705           iti=itortyp(itype(i))
6706         else
6707           iti=ntortyp+1
6708         endif
6709         itk1=itortyp(itype(k+1))
6710         itl=itortyp(itype(l))
6711         itj=itortyp(itype(j))
6712         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6713           itj1=itortyp(itype(j+1))
6714         else
6715           itj1=ntortyp+1
6716         endif
6717 C A2 kernel(j-1)T A1T
6718         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6719      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6720      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6721 C Following matrices are needed only for 6-th order cumulants
6722         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6723      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6724         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6725      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6726      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6727         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6728      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6729      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6730      &   ADtEAderx(1,1,1,1,1,1))
6731         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6732      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6733      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6734      &   ADtEA1derx(1,1,1,1,1,1))
6735         ENDIF
6736 C End 6-th order cumulants
6737         call transpose2(EUgder(1,1,k),auxmat(1,1))
6738         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6739         call transpose2(EUg(1,1,k),auxmat(1,1))
6740         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6741         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6742         do iii=1,2
6743           do kkk=1,5
6744             do lll=1,3
6745               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6746      &          EAEAderx(1,1,lll,kkk,iii,1))
6747             enddo
6748           enddo
6749         enddo
6750 C A2T kernel(i+1)T A1
6751         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6752      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6753      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6754 C Following matrices are needed only for 6-th order cumulants
6755         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6756      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6757         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6758      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6759      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6760         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6761      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6762      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6763      &   ADtEAderx(1,1,1,1,1,2))
6764         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6765      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6766      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6767      &   ADtEA1derx(1,1,1,1,1,2))
6768         ENDIF
6769 C End 6-th order cumulants
6770         call transpose2(EUgder(1,1,j),auxmat(1,1))
6771         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6772         call transpose2(EUg(1,1,j),auxmat(1,1))
6773         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6774         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6775         do iii=1,2
6776           do kkk=1,5
6777             do lll=1,3
6778               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6779      &          EAEAderx(1,1,lll,kkk,iii,2))
6780             enddo
6781           enddo
6782         enddo
6783 C AEAb1 and AEAb2
6784 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6785 C They are needed only when the fifth- or the sixth-order cumulants are
6786 C indluded.
6787         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6788      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6789         call transpose2(AEA(1,1,1),auxmat(1,1))
6790         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6791         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6792         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6793         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6794         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6795         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6796         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6797         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6798         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6799         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6800         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6801         call transpose2(AEA(1,1,2),auxmat(1,1))
6802         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6803         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6804         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6805         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6806         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6807         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6808         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6809         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6810         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6811         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6812         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6813 C Calculate the Cartesian derivatives of the vectors.
6814         do iii=1,2
6815           do kkk=1,5
6816             do lll=1,3
6817               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6818               call matvec2(auxmat(1,1),b1(1,iti),
6819      &          AEAb1derx(1,lll,kkk,iii,1,1))
6820               call matvec2(auxmat(1,1),Ub2(1,i),
6821      &          AEAb2derx(1,lll,kkk,iii,1,1))
6822               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6823      &          AEAb1derx(1,lll,kkk,iii,2,1))
6824               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6825      &          AEAb2derx(1,lll,kkk,iii,2,1))
6826               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6827               call matvec2(auxmat(1,1),b1(1,itl),
6828      &          AEAb1derx(1,lll,kkk,iii,1,2))
6829               call matvec2(auxmat(1,1),Ub2(1,l),
6830      &          AEAb2derx(1,lll,kkk,iii,1,2))
6831               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6832      &          AEAb1derx(1,lll,kkk,iii,2,2))
6833               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6834      &          AEAb2derx(1,lll,kkk,iii,2,2))
6835             enddo
6836           enddo
6837         enddo
6838         ENDIF
6839 C End vectors
6840       endif
6841       return
6842       end
6843 C---------------------------------------------------------------------------
6844       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6845      &  KK,KKderg,AKA,AKAderg,AKAderx)
6846       implicit none
6847       integer nderg
6848       logical transp
6849       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6850      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6851      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6852       integer iii,kkk,lll
6853       integer jjj,mmm
6854       logical lprn
6855       common /kutas/ lprn
6856       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6857       do iii=1,nderg
6858         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6859      &    AKAderg(1,1,iii))
6860       enddo
6861 cd      if (lprn) write (2,*) 'In kernel'
6862       do kkk=1,5
6863 cd        if (lprn) write (2,*) 'kkk=',kkk
6864         do lll=1,3
6865           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6866      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6867 cd          if (lprn) then
6868 cd            write (2,*) 'lll=',lll
6869 cd            write (2,*) 'iii=1'
6870 cd            do jjj=1,2
6871 cd              write (2,'(3(2f10.5),5x)')
6872 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6873 cd            enddo
6874 cd          endif
6875           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6876      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6877 cd          if (lprn) then
6878 cd            write (2,*) 'lll=',lll
6879 cd            write (2,*) 'iii=2'
6880 cd            do jjj=1,2
6881 cd              write (2,'(3(2f10.5),5x)')
6882 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6883 cd            enddo
6884 cd          endif
6885         enddo
6886       enddo
6887       return
6888       end
6889 C---------------------------------------------------------------------------
6890       double precision function eello4(i,j,k,l,jj,kk)
6891       implicit real*8 (a-h,o-z)
6892       include 'DIMENSIONS'
6893       include 'DIMENSIONS.ZSCOPT'
6894       include 'COMMON.IOUNITS'
6895       include 'COMMON.CHAIN'
6896       include 'COMMON.DERIV'
6897       include 'COMMON.INTERACT'
6898       include 'COMMON.CONTACTS'
6899       include 'COMMON.TORSION'
6900       include 'COMMON.VAR'
6901       include 'COMMON.GEO'
6902       double precision pizda(2,2),ggg1(3),ggg2(3)
6903 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6904 cd        eello4=0.0d0
6905 cd        return
6906 cd      endif
6907 cd      print *,'eello4:',i,j,k,l,jj,kk
6908 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6909 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6910 cold      eij=facont_hb(jj,i)
6911 cold      ekl=facont_hb(kk,k)
6912 cold      ekont=eij*ekl
6913       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6914       if (calc_grad) then
6915 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6916       gcorr_loc(k-1)=gcorr_loc(k-1)
6917      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6918       if (l.eq.j+1) then
6919         gcorr_loc(l-1)=gcorr_loc(l-1)
6920      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6921       else
6922         gcorr_loc(j-1)=gcorr_loc(j-1)
6923      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6924       endif
6925       do iii=1,2
6926         do kkk=1,5
6927           do lll=1,3
6928             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6929      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6930 cd            derx(lll,kkk,iii)=0.0d0
6931           enddo
6932         enddo
6933       enddo
6934 cd      gcorr_loc(l-1)=0.0d0
6935 cd      gcorr_loc(j-1)=0.0d0
6936 cd      gcorr_loc(k-1)=0.0d0
6937 cd      eel4=1.0d0
6938 cd      write (iout,*)'Contacts have occurred for peptide groups',
6939 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6940 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6941       if (j.lt.nres-1) then
6942         j1=j+1
6943         j2=j-1
6944       else
6945         j1=j-1
6946         j2=j-2
6947       endif
6948       if (l.lt.nres-1) then
6949         l1=l+1
6950         l2=l-1
6951       else
6952         l1=l-1
6953         l2=l-2
6954       endif
6955       do ll=1,3
6956 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6957         ggg1(ll)=eel4*g_contij(ll,1)
6958         ggg2(ll)=eel4*g_contij(ll,2)
6959         ghalf=0.5d0*ggg1(ll)
6960 cd        ghalf=0.0d0
6961         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6962         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6963         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6964         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6965 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6966         ghalf=0.5d0*ggg2(ll)
6967 cd        ghalf=0.0d0
6968         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6969         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6970         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6971         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6972       enddo
6973 cd      goto 1112
6974       do m=i+1,j-1
6975         do ll=1,3
6976 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6977           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6978         enddo
6979       enddo
6980       do m=k+1,l-1
6981         do ll=1,3
6982 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6983           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6984         enddo
6985       enddo
6986 1112  continue
6987       do m=i+2,j2
6988         do ll=1,3
6989           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6990         enddo
6991       enddo
6992       do m=k+2,l2
6993         do ll=1,3
6994           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6995         enddo
6996       enddo
6997 cd      do iii=1,nres-3
6998 cd        write (2,*) iii,gcorr_loc(iii)
6999 cd      enddo
7000       endif
7001       eello4=ekont*eel4
7002 cd      write (2,*) 'ekont',ekont
7003 cd      write (iout,*) 'eello4',ekont*eel4
7004       return
7005       end
7006 C---------------------------------------------------------------------------
7007       double precision function eello5(i,j,k,l,jj,kk)
7008       implicit real*8 (a-h,o-z)
7009       include 'DIMENSIONS'
7010       include 'DIMENSIONS.ZSCOPT'
7011       include 'COMMON.IOUNITS'
7012       include 'COMMON.CHAIN'
7013       include 'COMMON.DERIV'
7014       include 'COMMON.INTERACT'
7015       include 'COMMON.CONTACTS'
7016       include 'COMMON.TORSION'
7017       include 'COMMON.VAR'
7018       include 'COMMON.GEO'
7019       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7020       double precision ggg1(3),ggg2(3)
7021 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7022 C                                                                              C
7023 C                            Parallel chains                                   C
7024 C                                                                              C
7025 C          o             o                   o             o                   C
7026 C         /l\           / \             \   / \           / \   /              C
7027 C        /   \         /   \             \ /   \         /   \ /               C
7028 C       j| o |l1       | o |              o| o |         | o |o                C
7029 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7030 C      \i/   \         /   \ /             /   \         /   \                 C
7031 C       o    k1             o                                                  C
7032 C         (I)          (II)                (III)          (IV)                 C
7033 C                                                                              C
7034 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7035 C                                                                              C
7036 C                            Antiparallel chains                               C
7037 C                                                                              C
7038 C          o             o                   o             o                   C
7039 C         /j\           / \             \   / \           / \   /              C
7040 C        /   \         /   \             \ /   \         /   \ /               C
7041 C      j1| o |l        | o |              o| o |         | o |o                C
7042 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7043 C      \i/   \         /   \ /             /   \         /   \                 C
7044 C       o     k1            o                                                  C
7045 C         (I)          (II)                (III)          (IV)                 C
7046 C                                                                              C
7047 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7048 C                                                                              C
7049 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7050 C                                                                              C
7051 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7052 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7053 cd        eello5=0.0d0
7054 cd        return
7055 cd      endif
7056 cd      write (iout,*)
7057 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7058 cd     &   ' and',k,l
7059       itk=itortyp(itype(k))
7060       itl=itortyp(itype(l))
7061       itj=itortyp(itype(j))
7062       eello5_1=0.0d0
7063       eello5_2=0.0d0
7064       eello5_3=0.0d0
7065       eello5_4=0.0d0
7066 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7067 cd     &   eel5_3_num,eel5_4_num)
7068       do iii=1,2
7069         do kkk=1,5
7070           do lll=1,3
7071             derx(lll,kkk,iii)=0.0d0
7072           enddo
7073         enddo
7074       enddo
7075 cd      eij=facont_hb(jj,i)
7076 cd      ekl=facont_hb(kk,k)
7077 cd      ekont=eij*ekl
7078 cd      write (iout,*)'Contacts have occurred for peptide groups',
7079 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7080 cd      goto 1111
7081 C Contribution from the graph I.
7082 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7083 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7084       call transpose2(EUg(1,1,k),auxmat(1,1))
7085       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7086       vv(1)=pizda(1,1)-pizda(2,2)
7087       vv(2)=pizda(1,2)+pizda(2,1)
7088       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7089      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7090       if (calc_grad) then
7091 C Explicit gradient in virtual-dihedral angles.
7092       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7093      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7094      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7095       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7096       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7097       vv(1)=pizda(1,1)-pizda(2,2)
7098       vv(2)=pizda(1,2)+pizda(2,1)
7099       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7100      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7101      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7102       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7103       vv(1)=pizda(1,1)-pizda(2,2)
7104       vv(2)=pizda(1,2)+pizda(2,1)
7105       if (l.eq.j+1) then
7106         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7107      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7108      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7109       else
7110         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7111      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7112      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7113       endif
7114 C Cartesian gradient
7115       do iii=1,2
7116         do kkk=1,5
7117           do lll=1,3
7118             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7119      &        pizda(1,1))
7120             vv(1)=pizda(1,1)-pizda(2,2)
7121             vv(2)=pizda(1,2)+pizda(2,1)
7122             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7123      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7124      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7125           enddo
7126         enddo
7127       enddo
7128 c      goto 1112
7129       endif
7130 c1111  continue
7131 C Contribution from graph II
7132       call transpose2(EE(1,1,itk),auxmat(1,1))
7133       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7134       vv(1)=pizda(1,1)+pizda(2,2)
7135       vv(2)=pizda(2,1)-pizda(1,2)
7136       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7137      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7138       if (calc_grad) then
7139 C Explicit gradient in virtual-dihedral angles.
7140       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7141      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7142       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7143       vv(1)=pizda(1,1)+pizda(2,2)
7144       vv(2)=pizda(2,1)-pizda(1,2)
7145       if (l.eq.j+1) then
7146         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7147      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7148      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7149       else
7150         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7151      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7152      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7153       endif
7154 C Cartesian gradient
7155       do iii=1,2
7156         do kkk=1,5
7157           do lll=1,3
7158             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7159      &        pizda(1,1))
7160             vv(1)=pizda(1,1)+pizda(2,2)
7161             vv(2)=pizda(2,1)-pizda(1,2)
7162             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7163      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7164      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7165           enddo
7166         enddo
7167       enddo
7168 cd      goto 1112
7169       endif
7170 cd1111  continue
7171       if (l.eq.j+1) then
7172 cd        goto 1110
7173 C Parallel orientation
7174 C Contribution from graph III
7175         call transpose2(EUg(1,1,l),auxmat(1,1))
7176         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7177         vv(1)=pizda(1,1)-pizda(2,2)
7178         vv(2)=pizda(1,2)+pizda(2,1)
7179         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7180      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7181         if (calc_grad) then
7182 C Explicit gradient in virtual-dihedral angles.
7183         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7184      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7185      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7186         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7187         vv(1)=pizda(1,1)-pizda(2,2)
7188         vv(2)=pizda(1,2)+pizda(2,1)
7189         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7190      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7191      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7192         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7193         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7194         vv(1)=pizda(1,1)-pizda(2,2)
7195         vv(2)=pizda(1,2)+pizda(2,1)
7196         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7197      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7198      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7199 C Cartesian gradient
7200         do iii=1,2
7201           do kkk=1,5
7202             do lll=1,3
7203               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7204      &          pizda(1,1))
7205               vv(1)=pizda(1,1)-pizda(2,2)
7206               vv(2)=pizda(1,2)+pizda(2,1)
7207               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7208      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7209      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7210             enddo
7211           enddo
7212         enddo
7213 cd        goto 1112
7214         endif
7215 C Contribution from graph IV
7216 cd1110    continue
7217         call transpose2(EE(1,1,itl),auxmat(1,1))
7218         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7219         vv(1)=pizda(1,1)+pizda(2,2)
7220         vv(2)=pizda(2,1)-pizda(1,2)
7221         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7222      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7223         if (calc_grad) then
7224 C Explicit gradient in virtual-dihedral angles.
7225         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7226      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7227         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7228         vv(1)=pizda(1,1)+pizda(2,2)
7229         vv(2)=pizda(2,1)-pizda(1,2)
7230         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7231      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7232      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7233 C Cartesian gradient
7234         do iii=1,2
7235           do kkk=1,5
7236             do lll=1,3
7237               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7238      &          pizda(1,1))
7239               vv(1)=pizda(1,1)+pizda(2,2)
7240               vv(2)=pizda(2,1)-pizda(1,2)
7241               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7242      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7243      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7244             enddo
7245           enddo
7246         enddo
7247         endif
7248       else
7249 C Antiparallel orientation
7250 C Contribution from graph III
7251 c        goto 1110
7252         call transpose2(EUg(1,1,j),auxmat(1,1))
7253         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7254         vv(1)=pizda(1,1)-pizda(2,2)
7255         vv(2)=pizda(1,2)+pizda(2,1)
7256         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7257      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7258         if (calc_grad) then
7259 C Explicit gradient in virtual-dihedral angles.
7260         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7261      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7262      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7263         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7264         vv(1)=pizda(1,1)-pizda(2,2)
7265         vv(2)=pizda(1,2)+pizda(2,1)
7266         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7267      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7268      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7269         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7270         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7271         vv(1)=pizda(1,1)-pizda(2,2)
7272         vv(2)=pizda(1,2)+pizda(2,1)
7273         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7274      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7275      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7276 C Cartesian gradient
7277         do iii=1,2
7278           do kkk=1,5
7279             do lll=1,3
7280               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7281      &          pizda(1,1))
7282               vv(1)=pizda(1,1)-pizda(2,2)
7283               vv(2)=pizda(1,2)+pizda(2,1)
7284               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7285      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7286      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7287             enddo
7288           enddo
7289         enddo
7290 cd        goto 1112
7291         endif
7292 C Contribution from graph IV
7293 1110    continue
7294         call transpose2(EE(1,1,itj),auxmat(1,1))
7295         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7296         vv(1)=pizda(1,1)+pizda(2,2)
7297         vv(2)=pizda(2,1)-pizda(1,2)
7298         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7299      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7300         if (calc_grad) then
7301 C Explicit gradient in virtual-dihedral angles.
7302         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7303      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7304         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7305         vv(1)=pizda(1,1)+pizda(2,2)
7306         vv(2)=pizda(2,1)-pizda(1,2)
7307         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7308      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7309      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7310 C Cartesian gradient
7311         do iii=1,2
7312           do kkk=1,5
7313             do lll=1,3
7314               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7315      &          pizda(1,1))
7316               vv(1)=pizda(1,1)+pizda(2,2)
7317               vv(2)=pizda(2,1)-pizda(1,2)
7318               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7319      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7320      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7321             enddo
7322           enddo
7323         enddo
7324       endif
7325       endif
7326 1112  continue
7327       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7328 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7329 cd        write (2,*) 'ijkl',i,j,k,l
7330 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7331 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7332 cd      endif
7333 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7334 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7335 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7336 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7337       if (calc_grad) then
7338       if (j.lt.nres-1) then
7339         j1=j+1
7340         j2=j-1
7341       else
7342         j1=j-1
7343         j2=j-2
7344       endif
7345       if (l.lt.nres-1) then
7346         l1=l+1
7347         l2=l-1
7348       else
7349         l1=l-1
7350         l2=l-2
7351       endif
7352 cd      eij=1.0d0
7353 cd      ekl=1.0d0
7354 cd      ekont=1.0d0
7355 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7356       do ll=1,3
7357         ggg1(ll)=eel5*g_contij(ll,1)
7358         ggg2(ll)=eel5*g_contij(ll,2)
7359 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7360         ghalf=0.5d0*ggg1(ll)
7361 cd        ghalf=0.0d0
7362         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7363         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7364         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7365         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7366 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7367         ghalf=0.5d0*ggg2(ll)
7368 cd        ghalf=0.0d0
7369         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7370         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7371         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7372         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7373       enddo
7374 cd      goto 1112
7375       do m=i+1,j-1
7376         do ll=1,3
7377 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7378           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7379         enddo
7380       enddo
7381       do m=k+1,l-1
7382         do ll=1,3
7383 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7384           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7385         enddo
7386       enddo
7387 c1112  continue
7388       do m=i+2,j2
7389         do ll=1,3
7390           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7391         enddo
7392       enddo
7393       do m=k+2,l2
7394         do ll=1,3
7395           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7396         enddo
7397       enddo
7398 cd      do iii=1,nres-3
7399 cd        write (2,*) iii,g_corr5_loc(iii)
7400 cd      enddo
7401       endif
7402       eello5=ekont*eel5
7403 cd      write (2,*) 'ekont',ekont
7404 cd      write (iout,*) 'eello5',ekont*eel5
7405       return
7406       end
7407 c--------------------------------------------------------------------------
7408       double precision function eello6(i,j,k,l,jj,kk)
7409       implicit real*8 (a-h,o-z)
7410       include 'DIMENSIONS'
7411       include 'DIMENSIONS.ZSCOPT'
7412       include 'COMMON.IOUNITS'
7413       include 'COMMON.CHAIN'
7414       include 'COMMON.DERIV'
7415       include 'COMMON.INTERACT'
7416       include 'COMMON.CONTACTS'
7417       include 'COMMON.TORSION'
7418       include 'COMMON.VAR'
7419       include 'COMMON.GEO'
7420       include 'COMMON.FFIELD'
7421       double precision ggg1(3),ggg2(3)
7422 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7423 cd        eello6=0.0d0
7424 cd        return
7425 cd      endif
7426 cd      write (iout,*)
7427 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7428 cd     &   ' and',k,l
7429       eello6_1=0.0d0
7430       eello6_2=0.0d0
7431       eello6_3=0.0d0
7432       eello6_4=0.0d0
7433       eello6_5=0.0d0
7434       eello6_6=0.0d0
7435 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7436 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7437       do iii=1,2
7438         do kkk=1,5
7439           do lll=1,3
7440             derx(lll,kkk,iii)=0.0d0
7441           enddo
7442         enddo
7443       enddo
7444 cd      eij=facont_hb(jj,i)
7445 cd      ekl=facont_hb(kk,k)
7446 cd      ekont=eij*ekl
7447 cd      eij=1.0d0
7448 cd      ekl=1.0d0
7449 cd      ekont=1.0d0
7450       if (l.eq.j+1) then
7451         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7452         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7453         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7454         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7455         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7456         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7457       else
7458         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7459         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7460         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7461         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7462         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7463           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7464         else
7465           eello6_5=0.0d0
7466         endif
7467         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7468       endif
7469 C If turn contributions are considered, they will be handled separately.
7470       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7471 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7472 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7473 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7474 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7475 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7476 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7477 cd      goto 1112
7478       if (calc_grad) then
7479       if (j.lt.nres-1) then
7480         j1=j+1
7481         j2=j-1
7482       else
7483         j1=j-1
7484         j2=j-2
7485       endif
7486       if (l.lt.nres-1) then
7487         l1=l+1
7488         l2=l-1
7489       else
7490         l1=l-1
7491         l2=l-2
7492       endif
7493       do ll=1,3
7494         ggg1(ll)=eel6*g_contij(ll,1)
7495         ggg2(ll)=eel6*g_contij(ll,2)
7496 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7497         ghalf=0.5d0*ggg1(ll)
7498 cd        ghalf=0.0d0
7499         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7500         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7501         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7502         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7503         ghalf=0.5d0*ggg2(ll)
7504 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7505 cd        ghalf=0.0d0
7506         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7507         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7508         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7509         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7510       enddo
7511 cd      goto 1112
7512       do m=i+1,j-1
7513         do ll=1,3
7514 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7515           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7516         enddo
7517       enddo
7518       do m=k+1,l-1
7519         do ll=1,3
7520 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7521           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7522         enddo
7523       enddo
7524 1112  continue
7525       do m=i+2,j2
7526         do ll=1,3
7527           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7528         enddo
7529       enddo
7530       do m=k+2,l2
7531         do ll=1,3
7532           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7533         enddo
7534       enddo
7535 cd      do iii=1,nres-3
7536 cd        write (2,*) iii,g_corr6_loc(iii)
7537 cd      enddo
7538       endif
7539       eello6=ekont*eel6
7540 cd      write (2,*) 'ekont',ekont
7541 cd      write (iout,*) 'eello6',ekont*eel6
7542       return
7543       end
7544 c--------------------------------------------------------------------------
7545       double precision function eello6_graph1(i,j,k,l,imat,swap)
7546       implicit real*8 (a-h,o-z)
7547       include 'DIMENSIONS'
7548       include 'DIMENSIONS.ZSCOPT'
7549       include 'COMMON.IOUNITS'
7550       include 'COMMON.CHAIN'
7551       include 'COMMON.DERIV'
7552       include 'COMMON.INTERACT'
7553       include 'COMMON.CONTACTS'
7554       include 'COMMON.TORSION'
7555       include 'COMMON.VAR'
7556       include 'COMMON.GEO'
7557       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7558       logical swap
7559       logical lprn
7560       common /kutas/ lprn
7561 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7562 C                                                                              C
7563 C      Parallel       Antiparallel                                             C
7564 C                                                                              C
7565 C          o             o                                                     C
7566 C         /l\           /j\                                                    C
7567 C        /   \         /   \                                                   C
7568 C       /| o |         | o |\                                                  C
7569 C     \ j|/k\|  /   \  |/k\|l /                                                C
7570 C      \ /   \ /     \ /   \ /                                                 C
7571 C       o     o       o     o                                                  C
7572 C       i             i                                                        C
7573 C                                                                              C
7574 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7575       itk=itortyp(itype(k))
7576       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7577       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7578       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7579       call transpose2(EUgC(1,1,k),auxmat(1,1))
7580       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7581       vv1(1)=pizda1(1,1)-pizda1(2,2)
7582       vv1(2)=pizda1(1,2)+pizda1(2,1)
7583       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7584       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7585       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7586       s5=scalar2(vv(1),Dtobr2(1,i))
7587 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7588       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7589       if (.not. calc_grad) return
7590       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7591      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7592      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7593      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7594      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7595      & +scalar2(vv(1),Dtobr2der(1,i)))
7596       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7597       vv1(1)=pizda1(1,1)-pizda1(2,2)
7598       vv1(2)=pizda1(1,2)+pizda1(2,1)
7599       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7600       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7601       if (l.eq.j+1) then
7602         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7603      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7604      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7605      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7606      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7607       else
7608         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7609      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7610      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7611      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7612      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7613       endif
7614       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7615       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7616       vv1(1)=pizda1(1,1)-pizda1(2,2)
7617       vv1(2)=pizda1(1,2)+pizda1(2,1)
7618       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7619      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7620      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7621      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7622       do iii=1,2
7623         if (swap) then
7624           ind=3-iii
7625         else
7626           ind=iii
7627         endif
7628         do kkk=1,5
7629           do lll=1,3
7630             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7631             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7632             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7633             call transpose2(EUgC(1,1,k),auxmat(1,1))
7634             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7635      &        pizda1(1,1))
7636             vv1(1)=pizda1(1,1)-pizda1(2,2)
7637             vv1(2)=pizda1(1,2)+pizda1(2,1)
7638             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7639             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7640      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7641             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7642      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7643             s5=scalar2(vv(1),Dtobr2(1,i))
7644             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7645           enddo
7646         enddo
7647       enddo
7648       return
7649       end
7650 c----------------------------------------------------------------------------
7651       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7652       implicit real*8 (a-h,o-z)
7653       include 'DIMENSIONS'
7654       include 'DIMENSIONS.ZSCOPT'
7655       include 'COMMON.IOUNITS'
7656       include 'COMMON.CHAIN'
7657       include 'COMMON.DERIV'
7658       include 'COMMON.INTERACT'
7659       include 'COMMON.CONTACTS'
7660       include 'COMMON.TORSION'
7661       include 'COMMON.VAR'
7662       include 'COMMON.GEO'
7663       logical swap
7664       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7665      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7666       logical lprn
7667       common /kutas/ lprn
7668 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7669 C                                                                              C
7670 C      Parallel       Antiparallel                                             C
7671 C                                                                              C
7672 C          o             o                                                     C
7673 C     \   /l\           /j\   /                                                C
7674 C      \ /   \         /   \ /                                                 C
7675 C       o| o |         | o |o                                                  C
7676 C     \ j|/k\|      \  |/k\|l                                                  C
7677 C      \ /   \       \ /   \                                                   C
7678 C       o             o                                                        C
7679 C       i             i                                                        C
7680 C                                                                              C
7681 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7682 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7683 C AL 7/4/01 s1 would occur in the sixth-order moment,
7684 C           but not in a cluster cumulant
7685 #ifdef MOMENT
7686       s1=dip(1,jj,i)*dip(1,kk,k)
7687 #endif
7688       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7689       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7690       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7691       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7692       call transpose2(EUg(1,1,k),auxmat(1,1))
7693       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7694       vv(1)=pizda(1,1)-pizda(2,2)
7695       vv(2)=pizda(1,2)+pizda(2,1)
7696       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7697 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7698 #ifdef MOMENT
7699       eello6_graph2=-(s1+s2+s3+s4)
7700 #else
7701       eello6_graph2=-(s2+s3+s4)
7702 #endif
7703 c      eello6_graph2=-s3
7704       if (.not. calc_grad) return
7705 C Derivatives in gamma(i-1)
7706       if (i.gt.1) then
7707 #ifdef MOMENT
7708         s1=dipderg(1,jj,i)*dip(1,kk,k)
7709 #endif
7710         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7711         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7712         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7713         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7714 #ifdef MOMENT
7715         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7716 #else
7717         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7718 #endif
7719 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7720       endif
7721 C Derivatives in gamma(k-1)
7722 #ifdef MOMENT
7723       s1=dip(1,jj,i)*dipderg(1,kk,k)
7724 #endif
7725       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7726       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7727       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7728       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7729       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7730       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7731       vv(1)=pizda(1,1)-pizda(2,2)
7732       vv(2)=pizda(1,2)+pizda(2,1)
7733       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7734 #ifdef MOMENT
7735       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7736 #else
7737       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7738 #endif
7739 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7740 C Derivatives in gamma(j-1) or gamma(l-1)
7741       if (j.gt.1) then
7742 #ifdef MOMENT
7743         s1=dipderg(3,jj,i)*dip(1,kk,k)
7744 #endif
7745         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7746         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7747         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7748         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7749         vv(1)=pizda(1,1)-pizda(2,2)
7750         vv(2)=pizda(1,2)+pizda(2,1)
7751         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7752 #ifdef MOMENT
7753         if (swap) then
7754           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7755         else
7756           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7757         endif
7758 #endif
7759         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7760 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7761       endif
7762 C Derivatives in gamma(l-1) or gamma(j-1)
7763       if (l.gt.1) then
7764 #ifdef MOMENT
7765         s1=dip(1,jj,i)*dipderg(3,kk,k)
7766 #endif
7767         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7768         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7769         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7770         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7771         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7772         vv(1)=pizda(1,1)-pizda(2,2)
7773         vv(2)=pizda(1,2)+pizda(2,1)
7774         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7775 #ifdef MOMENT
7776         if (swap) then
7777           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7778         else
7779           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7780         endif
7781 #endif
7782         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7783 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7784       endif
7785 C Cartesian derivatives.
7786       if (lprn) then
7787         write (2,*) 'In eello6_graph2'
7788         do iii=1,2
7789           write (2,*) 'iii=',iii
7790           do kkk=1,5
7791             write (2,*) 'kkk=',kkk
7792             do jjj=1,2
7793               write (2,'(3(2f10.5),5x)')
7794      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7795             enddo
7796           enddo
7797         enddo
7798       endif
7799       do iii=1,2
7800         do kkk=1,5
7801           do lll=1,3
7802 #ifdef MOMENT
7803             if (iii.eq.1) then
7804               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7805             else
7806               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7807             endif
7808 #endif
7809             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7810      &        auxvec(1))
7811             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7812             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7813      &        auxvec(1))
7814             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7815             call transpose2(EUg(1,1,k),auxmat(1,1))
7816             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7817      &        pizda(1,1))
7818             vv(1)=pizda(1,1)-pizda(2,2)
7819             vv(2)=pizda(1,2)+pizda(2,1)
7820             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7821 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7822 #ifdef MOMENT
7823             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7824 #else
7825             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7826 #endif
7827             if (swap) then
7828               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7829             else
7830               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7831             endif
7832           enddo
7833         enddo
7834       enddo
7835       return
7836       end
7837 c----------------------------------------------------------------------------
7838       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7839       implicit real*8 (a-h,o-z)
7840       include 'DIMENSIONS'
7841       include 'DIMENSIONS.ZSCOPT'
7842       include 'COMMON.IOUNITS'
7843       include 'COMMON.CHAIN'
7844       include 'COMMON.DERIV'
7845       include 'COMMON.INTERACT'
7846       include 'COMMON.CONTACTS'
7847       include 'COMMON.TORSION'
7848       include 'COMMON.VAR'
7849       include 'COMMON.GEO'
7850       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7851       logical swap
7852 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7853 C                                                                              C
7854 C      Parallel       Antiparallel                                             C
7855 C                                                                              C
7856 C          o             o                                                     C
7857 C         /l\   /   \   /j\                                                    C
7858 C        /   \ /     \ /   \                                                   C
7859 C       /| o |o       o| o |\                                                  C
7860 C       j|/k\|  /      |/k\|l /                                                C
7861 C        /   \ /       /   \ /                                                 C
7862 C       /     o       /     o                                                  C
7863 C       i             i                                                        C
7864 C                                                                              C
7865 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7866 C
7867 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7868 C           energy moment and not to the cluster cumulant.
7869       iti=itortyp(itype(i))
7870       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7871         itj1=itortyp(itype(j+1))
7872       else
7873         itj1=ntortyp+1
7874       endif
7875       itk=itortyp(itype(k))
7876       itk1=itortyp(itype(k+1))
7877       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7878         itl1=itortyp(itype(l+1))
7879       else
7880         itl1=ntortyp+1
7881       endif
7882 #ifdef MOMENT
7883       s1=dip(4,jj,i)*dip(4,kk,k)
7884 #endif
7885       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7886       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7887       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7888       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7889       call transpose2(EE(1,1,itk),auxmat(1,1))
7890       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7891       vv(1)=pizda(1,1)+pizda(2,2)
7892       vv(2)=pizda(2,1)-pizda(1,2)
7893       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7894 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7895 #ifdef MOMENT
7896       eello6_graph3=-(s1+s2+s3+s4)
7897 #else
7898       eello6_graph3=-(s2+s3+s4)
7899 #endif
7900 c      eello6_graph3=-s4
7901       if (.not. calc_grad) return
7902 C Derivatives in gamma(k-1)
7903       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7904       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7905       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7906       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7907 C Derivatives in gamma(l-1)
7908       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7909       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7910       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7911       vv(1)=pizda(1,1)+pizda(2,2)
7912       vv(2)=pizda(2,1)-pizda(1,2)
7913       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7914       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7915 C Cartesian derivatives.
7916       do iii=1,2
7917         do kkk=1,5
7918           do lll=1,3
7919 #ifdef MOMENT
7920             if (iii.eq.1) then
7921               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7922             else
7923               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7924             endif
7925 #endif
7926             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7927      &        auxvec(1))
7928             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7929             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7930      &        auxvec(1))
7931             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7932             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7933      &        pizda(1,1))
7934             vv(1)=pizda(1,1)+pizda(2,2)
7935             vv(2)=pizda(2,1)-pizda(1,2)
7936             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7937 #ifdef MOMENT
7938             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7939 #else
7940             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7941 #endif
7942             if (swap) then
7943               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7944             else
7945               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7946             endif
7947 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7948           enddo
7949         enddo
7950       enddo
7951       return
7952       end
7953 c----------------------------------------------------------------------------
7954       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7955       implicit real*8 (a-h,o-z)
7956       include 'DIMENSIONS'
7957       include 'DIMENSIONS.ZSCOPT'
7958       include 'COMMON.IOUNITS'
7959       include 'COMMON.CHAIN'
7960       include 'COMMON.DERIV'
7961       include 'COMMON.INTERACT'
7962       include 'COMMON.CONTACTS'
7963       include 'COMMON.TORSION'
7964       include 'COMMON.VAR'
7965       include 'COMMON.GEO'
7966       include 'COMMON.FFIELD'
7967       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7968      & auxvec1(2),auxmat1(2,2)
7969       logical swap
7970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7971 C                                                                              C
7972 C      Parallel       Antiparallel                                             C
7973 C                                                                              C
7974 C          o             o                                                     C
7975 C         /l\   /   \   /j\                                                    C
7976 C        /   \ /     \ /   \                                                   C
7977 C       /| o |o       o| o |\                                                  C
7978 C     \ j|/k\|      \  |/k\|l                                                  C
7979 C      \ /   \       \ /   \                                                   C
7980 C       o     \       o     \                                                  C
7981 C       i             i                                                        C
7982 C                                                                              C
7983 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7984 C
7985 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7986 C           energy moment and not to the cluster cumulant.
7987 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7988       iti=itortyp(itype(i))
7989       itj=itortyp(itype(j))
7990       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7991         itj1=itortyp(itype(j+1))
7992       else
7993         itj1=ntortyp+1
7994       endif
7995       itk=itortyp(itype(k))
7996       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7997         itk1=itortyp(itype(k+1))
7998       else
7999         itk1=ntortyp+1
8000       endif
8001       itl=itortyp(itype(l))
8002       if (l.lt.nres-1) then
8003         itl1=itortyp(itype(l+1))
8004       else
8005         itl1=ntortyp+1
8006       endif
8007 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8008 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8009 cd     & ' itl',itl,' itl1',itl1
8010 #ifdef MOMENT
8011       if (imat.eq.1) then
8012         s1=dip(3,jj,i)*dip(3,kk,k)
8013       else
8014         s1=dip(2,jj,j)*dip(2,kk,l)
8015       endif
8016 #endif
8017       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8018       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8019       if (j.eq.l+1) then
8020         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8021         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8022       else
8023         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8024         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8025       endif
8026       call transpose2(EUg(1,1,k),auxmat(1,1))
8027       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8028       vv(1)=pizda(1,1)-pizda(2,2)
8029       vv(2)=pizda(2,1)+pizda(1,2)
8030       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8031 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8032 #ifdef MOMENT
8033       eello6_graph4=-(s1+s2+s3+s4)
8034 #else
8035       eello6_graph4=-(s2+s3+s4)
8036 #endif
8037       if (.not. calc_grad) return
8038 C Derivatives in gamma(i-1)
8039       if (i.gt.1) then
8040 #ifdef MOMENT
8041         if (imat.eq.1) then
8042           s1=dipderg(2,jj,i)*dip(3,kk,k)
8043         else
8044           s1=dipderg(4,jj,j)*dip(2,kk,l)
8045         endif
8046 #endif
8047         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8048         if (j.eq.l+1) then
8049           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8050           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8051         else
8052           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8053           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8054         endif
8055         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8056         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8057 cd          write (2,*) 'turn6 derivatives'
8058 #ifdef MOMENT
8059           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8060 #else
8061           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8062 #endif
8063         else
8064 #ifdef MOMENT
8065           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8066 #else
8067           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8068 #endif
8069         endif
8070       endif
8071 C Derivatives in gamma(k-1)
8072 #ifdef MOMENT
8073       if (imat.eq.1) then
8074         s1=dip(3,jj,i)*dipderg(2,kk,k)
8075       else
8076         s1=dip(2,jj,j)*dipderg(4,kk,l)
8077       endif
8078 #endif
8079       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8080       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8081       if (j.eq.l+1) then
8082         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8083         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8084       else
8085         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8086         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8087       endif
8088       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8089       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8090       vv(1)=pizda(1,1)-pizda(2,2)
8091       vv(2)=pizda(2,1)+pizda(1,2)
8092       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8093       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8094 #ifdef MOMENT
8095         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8096 #else
8097         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8098 #endif
8099       else
8100 #ifdef MOMENT
8101         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8102 #else
8103         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8104 #endif
8105       endif
8106 C Derivatives in gamma(j-1) or gamma(l-1)
8107       if (l.eq.j+1 .and. l.gt.1) then
8108         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8109         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8110         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8111         vv(1)=pizda(1,1)-pizda(2,2)
8112         vv(2)=pizda(2,1)+pizda(1,2)
8113         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8114         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8115       else if (j.gt.1) then
8116         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8117         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8118         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8119         vv(1)=pizda(1,1)-pizda(2,2)
8120         vv(2)=pizda(2,1)+pizda(1,2)
8121         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8122         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8123           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8124         else
8125           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8126         endif
8127       endif
8128 C Cartesian derivatives.
8129       do iii=1,2
8130         do kkk=1,5
8131           do lll=1,3
8132 #ifdef MOMENT
8133             if (iii.eq.1) then
8134               if (imat.eq.1) then
8135                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8136               else
8137                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8138               endif
8139             else
8140               if (imat.eq.1) then
8141                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8142               else
8143                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8144               endif
8145             endif
8146 #endif
8147             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8148      &        auxvec(1))
8149             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8150             if (j.eq.l+1) then
8151               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8152      &          b1(1,itj1),auxvec(1))
8153               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8154             else
8155               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8156      &          b1(1,itl1),auxvec(1))
8157               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8158             endif
8159             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8160      &        pizda(1,1))
8161             vv(1)=pizda(1,1)-pizda(2,2)
8162             vv(2)=pizda(2,1)+pizda(1,2)
8163             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8164             if (swap) then
8165               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8166 #ifdef MOMENT
8167                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8168      &             -(s1+s2+s4)
8169 #else
8170                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8171      &             -(s2+s4)
8172 #endif
8173                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8174               else
8175 #ifdef MOMENT
8176                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8177 #else
8178                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8179 #endif
8180                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8181               endif
8182             else
8183 #ifdef MOMENT
8184               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8185 #else
8186               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8187 #endif
8188               if (l.eq.j+1) then
8189                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8190               else
8191                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8192               endif
8193             endif
8194           enddo
8195         enddo
8196       enddo
8197       return
8198       end
8199 c----------------------------------------------------------------------------
8200       double precision function eello_turn6(i,jj,kk)
8201       implicit real*8 (a-h,o-z)
8202       include 'DIMENSIONS'
8203       include 'DIMENSIONS.ZSCOPT'
8204       include 'COMMON.IOUNITS'
8205       include 'COMMON.CHAIN'
8206       include 'COMMON.DERIV'
8207       include 'COMMON.INTERACT'
8208       include 'COMMON.CONTACTS'
8209       include 'COMMON.TORSION'
8210       include 'COMMON.VAR'
8211       include 'COMMON.GEO'
8212       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8213      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8214      &  ggg1(3),ggg2(3)
8215       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8216      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8217 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8218 C           the respective energy moment and not to the cluster cumulant.
8219       eello_turn6=0.0d0
8220       j=i+4
8221       k=i+1
8222       l=i+3
8223       iti=itortyp(itype(i))
8224       itk=itortyp(itype(k))
8225       itk1=itortyp(itype(k+1))
8226       itl=itortyp(itype(l))
8227       itj=itortyp(itype(j))
8228 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8229 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8230 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8231 cd        eello6=0.0d0
8232 cd        return
8233 cd      endif
8234 cd      write (iout,*)
8235 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8236 cd     &   ' and',k,l
8237 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8238       do iii=1,2
8239         do kkk=1,5
8240           do lll=1,3
8241             derx_turn(lll,kkk,iii)=0.0d0
8242           enddo
8243         enddo
8244       enddo
8245 cd      eij=1.0d0
8246 cd      ekl=1.0d0
8247 cd      ekont=1.0d0
8248       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8249 cd      eello6_5=0.0d0
8250 cd      write (2,*) 'eello6_5',eello6_5
8251 #ifdef MOMENT
8252       call transpose2(AEA(1,1,1),auxmat(1,1))
8253       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8254       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8255       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8256 #else
8257       s1 = 0.0d0
8258 #endif
8259       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8260       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8261       s2 = scalar2(b1(1,itk),vtemp1(1))
8262 #ifdef MOMENT
8263       call transpose2(AEA(1,1,2),atemp(1,1))
8264       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8265       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8266       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8267 #else
8268       s8=0.0d0
8269 #endif
8270       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8271       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8272       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8273 #ifdef MOMENT
8274       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8275       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8276       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8277       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8278       ss13 = scalar2(b1(1,itk),vtemp4(1))
8279       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8280 #else
8281       s13=0.0d0
8282 #endif
8283 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8284 c      s1=0.0d0
8285 c      s2=0.0d0
8286 c      s8=0.0d0
8287 c      s12=0.0d0
8288 c      s13=0.0d0
8289       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8290       if (calc_grad) then
8291 C Derivatives in gamma(i+2)
8292 #ifdef MOMENT
8293       call transpose2(AEA(1,1,1),auxmatd(1,1))
8294       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8295       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8296       call transpose2(AEAderg(1,1,2),atempd(1,1))
8297       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8298       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8299 #else
8300       s8d=0.0d0
8301 #endif
8302       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8303       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8304       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8305 c      s1d=0.0d0
8306 c      s2d=0.0d0
8307 c      s8d=0.0d0
8308 c      s12d=0.0d0
8309 c      s13d=0.0d0
8310       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8311 C Derivatives in gamma(i+3)
8312 #ifdef MOMENT
8313       call transpose2(AEA(1,1,1),auxmatd(1,1))
8314       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8315       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8316       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8317 #else
8318       s1d=0.0d0
8319 #endif
8320       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8321       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8322       s2d = scalar2(b1(1,itk),vtemp1d(1))
8323 #ifdef MOMENT
8324       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8325       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8326 #endif
8327       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8328 #ifdef MOMENT
8329       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8330       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8331       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8332 #else
8333       s13d=0.0d0
8334 #endif
8335 c      s1d=0.0d0
8336 c      s2d=0.0d0
8337 c      s8d=0.0d0
8338 c      s12d=0.0d0
8339 c      s13d=0.0d0
8340 #ifdef MOMENT
8341       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8342      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8343 #else
8344       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8345      &               -0.5d0*ekont*(s2d+s12d)
8346 #endif
8347 C Derivatives in gamma(i+4)
8348       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8349       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8350       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8351 #ifdef MOMENT
8352       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8353       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8354       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8355 #else
8356       s13d = 0.0d0
8357 #endif
8358 c      s1d=0.0d0
8359 c      s2d=0.0d0
8360 c      s8d=0.0d0
8361 C      s12d=0.0d0
8362 c      s13d=0.0d0
8363 #ifdef MOMENT
8364       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8365 #else
8366       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8367 #endif
8368 C Derivatives in gamma(i+5)
8369 #ifdef MOMENT
8370       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8371       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8372       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8373 #else
8374       s1d = 0.0d0
8375 #endif
8376       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8377       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8378       s2d = scalar2(b1(1,itk),vtemp1d(1))
8379 #ifdef MOMENT
8380       call transpose2(AEA(1,1,2),atempd(1,1))
8381       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8382       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8383 #else
8384       s8d = 0.0d0
8385 #endif
8386       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8387       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8388 #ifdef MOMENT
8389       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8390       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8391       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8392 #else
8393       s13d = 0.0d0
8394 #endif
8395 c      s1d=0.0d0
8396 c      s2d=0.0d0
8397 c      s8d=0.0d0
8398 c      s12d=0.0d0
8399 c      s13d=0.0d0
8400 #ifdef MOMENT
8401       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8402      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8403 #else
8404       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8405      &               -0.5d0*ekont*(s2d+s12d)
8406 #endif
8407 C Cartesian derivatives
8408       do iii=1,2
8409         do kkk=1,5
8410           do lll=1,3
8411 #ifdef MOMENT
8412             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8413             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8414             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8415 #else
8416             s1d = 0.0d0
8417 #endif
8418             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8419             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8420      &          vtemp1d(1))
8421             s2d = scalar2(b1(1,itk),vtemp1d(1))
8422 #ifdef MOMENT
8423             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8424             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8425             s8d = -(atempd(1,1)+atempd(2,2))*
8426      &           scalar2(cc(1,1,itl),vtemp2(1))
8427 #else
8428             s8d = 0.0d0
8429 #endif
8430             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8431      &           auxmatd(1,1))
8432             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8433             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8434 c      s1d=0.0d0
8435 c      s2d=0.0d0
8436 c      s8d=0.0d0
8437 c      s12d=0.0d0
8438 c      s13d=0.0d0
8439 #ifdef MOMENT
8440             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8441      &        - 0.5d0*(s1d+s2d)
8442 #else
8443             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8444      &        - 0.5d0*s2d
8445 #endif
8446 #ifdef MOMENT
8447             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8448      &        - 0.5d0*(s8d+s12d)
8449 #else
8450             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8451      &        - 0.5d0*s12d
8452 #endif
8453           enddo
8454         enddo
8455       enddo
8456 #ifdef MOMENT
8457       do kkk=1,5
8458         do lll=1,3
8459           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8460      &      achuj_tempd(1,1))
8461           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8462           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8463           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8464           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8465           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8466      &      vtemp4d(1))
8467           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8468           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8469           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8470         enddo
8471       enddo
8472 #endif
8473 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8474 cd     &  16*eel_turn6_num
8475 cd      goto 1112
8476       if (j.lt.nres-1) then
8477         j1=j+1
8478         j2=j-1
8479       else
8480         j1=j-1
8481         j2=j-2
8482       endif
8483       if (l.lt.nres-1) then
8484         l1=l+1
8485         l2=l-1
8486       else
8487         l1=l-1
8488         l2=l-2
8489       endif
8490       do ll=1,3
8491         ggg1(ll)=eel_turn6*g_contij(ll,1)
8492         ggg2(ll)=eel_turn6*g_contij(ll,2)
8493         ghalf=0.5d0*ggg1(ll)
8494 cd        ghalf=0.0d0
8495         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8496      &    +ekont*derx_turn(ll,2,1)
8497         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8498         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8499      &    +ekont*derx_turn(ll,4,1)
8500         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8501         ghalf=0.5d0*ggg2(ll)
8502 cd        ghalf=0.0d0
8503         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8504      &    +ekont*derx_turn(ll,2,2)
8505         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8506         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8507      &    +ekont*derx_turn(ll,4,2)
8508         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8509       enddo
8510 cd      goto 1112
8511       do m=i+1,j-1
8512         do ll=1,3
8513           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8514         enddo
8515       enddo
8516       do m=k+1,l-1
8517         do ll=1,3
8518           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8519         enddo
8520       enddo
8521 1112  continue
8522       do m=i+2,j2
8523         do ll=1,3
8524           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8525         enddo
8526       enddo
8527       do m=k+2,l2
8528         do ll=1,3
8529           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8530         enddo
8531       enddo
8532 cd      do iii=1,nres-3
8533 cd        write (2,*) iii,g_corr6_loc(iii)
8534 cd      enddo
8535       endif
8536       eello_turn6=ekont*eel_turn6
8537 cd      write (2,*) 'ekont',ekont
8538 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8539       return
8540       end
8541 crc-------------------------------------------------
8542 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8543       subroutine Eliptransfer(eliptran)
8544       implicit real*8 (a-h,o-z)
8545       include 'DIMENSIONS'
8546       include 'COMMON.GEO'
8547       include 'COMMON.VAR'
8548       include 'COMMON.LOCAL'
8549       include 'COMMON.CHAIN'
8550       include 'COMMON.DERIV'
8551       include 'COMMON.INTERACT'
8552       include 'COMMON.IOUNITS'
8553       include 'COMMON.CALC'
8554       include 'COMMON.CONTROL'
8555       include 'COMMON.SPLITELE'
8556       include 'COMMON.SBRIDGE'
8557 C this is done by Adasko
8558 C      print *,"wchodze"
8559 C structure of box:
8560 C      water
8561 C--bordliptop-- buffore starts
8562 C--bufliptop--- here true lipid starts
8563 C      lipid
8564 C--buflipbot--- lipid ends buffore starts
8565 C--bordlipbot--buffore ends
8566       eliptran=0.0
8567       do i=1,nres
8568 C       do i=1,1
8569         if (itype(i).eq.ntyp1) cycle
8570
8571         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8572         if (positi.le.0) positi=positi+boxzsize
8573 C        print *,i
8574 C first for peptide groups
8575 c for each residue check if it is in lipid or lipid water border area
8576        if ((positi.gt.bordlipbot)
8577      &.and.(positi.lt.bordliptop)) then
8578 C the energy transfer exist
8579         if (positi.lt.buflipbot) then
8580 C what fraction I am in
8581          fracinbuf=1.0d0-
8582      &        ((positi-bordlipbot)/lipbufthick)
8583 C lipbufthick is thickenes of lipid buffore
8584          sslip=sscalelip(fracinbuf)
8585          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8586          eliptran=eliptran+sslip*pepliptran
8587          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8588          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8589 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8590         elseif (positi.gt.bufliptop) then
8591          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8592          sslip=sscalelip(fracinbuf)
8593          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8594          eliptran=eliptran+sslip*pepliptran
8595          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8596          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8597 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8598 C          print *, "doing sscalefor top part"
8599 C         print *,i,sslip,fracinbuf,ssgradlip
8600         else
8601          eliptran=eliptran+pepliptran
8602 C         print *,"I am in true lipid"
8603         endif
8604 C       else
8605 C       eliptran=elpitran+0.0 ! I am in water
8606        endif
8607        enddo
8608 C       print *, "nic nie bylo w lipidzie?"
8609 C now multiply all by the peptide group transfer factor
8610 C       eliptran=eliptran*pepliptran
8611 C now the same for side chains
8612 CV       do i=1,1
8613        do i=1,nres
8614         if (itype(i).eq.ntyp1) cycle
8615         positi=(mod(c(3,i+nres),boxzsize))
8616         if (positi.le.0) positi=positi+boxzsize
8617 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8618 c for each residue check if it is in lipid or lipid water border area
8619 C       respos=mod(c(3,i+nres),boxzsize)
8620 C       print *,positi,bordlipbot,buflipbot
8621        if ((positi.gt.bordlipbot)
8622      & .and.(positi.lt.bordliptop)) then
8623 C the energy transfer exist
8624         if (positi.lt.buflipbot) then
8625          fracinbuf=1.0d0-
8626      &     ((positi-bordlipbot)/lipbufthick)
8627 C lipbufthick is thickenes of lipid buffore
8628          sslip=sscalelip(fracinbuf)
8629          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8630          eliptran=eliptran+sslip*liptranene(itype(i))
8631          gliptranx(3,i)=gliptranx(3,i)
8632      &+ssgradlip*liptranene(itype(i))
8633          gliptranc(3,i-1)= gliptranc(3,i-1)
8634      &+ssgradlip*liptranene(itype(i))
8635 C         print *,"doing sccale for lower part"
8636         elseif (positi.gt.bufliptop) then
8637          fracinbuf=1.0d0-
8638      &((bordliptop-positi)/lipbufthick)
8639          sslip=sscalelip(fracinbuf)
8640          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8641          eliptran=eliptran+sslip*liptranene(itype(i))
8642          gliptranx(3,i)=gliptranx(3,i)
8643      &+ssgradlip*liptranene(itype(i))
8644          gliptranc(3,i-1)= gliptranc(3,i-1)
8645      &+ssgradlip*liptranene(itype(i))
8646 C          print *, "doing sscalefor top part",sslip,fracinbuf
8647         else
8648          eliptran=eliptran+liptranene(itype(i))
8649 C         print *,"I am in true lipid"
8650         endif
8651         endif ! if in lipid or buffor
8652 C       else
8653 C       eliptran=elpitran+0.0 ! I am in water
8654        enddo
8655        return
8656        end
8657
8658
8659 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8660
8661       SUBROUTINE MATVEC2(A1,V1,V2)
8662       implicit real*8 (a-h,o-z)
8663       include 'DIMENSIONS'
8664       DIMENSION A1(2,2),V1(2),V2(2)
8665 c      DO 1 I=1,2
8666 c        VI=0.0
8667 c        DO 3 K=1,2
8668 c    3     VI=VI+A1(I,K)*V1(K)
8669 c        Vaux(I)=VI
8670 c    1 CONTINUE
8671
8672       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8673       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8674
8675       v2(1)=vaux1
8676       v2(2)=vaux2
8677       END
8678 C---------------------------------------
8679       SUBROUTINE MATMAT2(A1,A2,A3)
8680       implicit real*8 (a-h,o-z)
8681       include 'DIMENSIONS'
8682       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8683 c      DIMENSION AI3(2,2)
8684 c        DO  J=1,2
8685 c          A3IJ=0.0
8686 c          DO K=1,2
8687 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8688 c          enddo
8689 c          A3(I,J)=A3IJ
8690 c       enddo
8691 c      enddo
8692
8693       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8694       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8695       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8696       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8697
8698       A3(1,1)=AI3_11
8699       A3(2,1)=AI3_21
8700       A3(1,2)=AI3_12
8701       A3(2,2)=AI3_22
8702       END
8703
8704 c-------------------------------------------------------------------------
8705       double precision function scalar2(u,v)
8706       implicit none
8707       double precision u(2),v(2)
8708       double precision sc
8709       integer i
8710       scalar2=u(1)*v(1)+u(2)*v(2)
8711       return
8712       end
8713
8714 C-----------------------------------------------------------------------------
8715
8716       subroutine transpose2(a,at)
8717       implicit none
8718       double precision a(2,2),at(2,2)
8719       at(1,1)=a(1,1)
8720       at(1,2)=a(2,1)
8721       at(2,1)=a(1,2)
8722       at(2,2)=a(2,2)
8723       return
8724       end
8725 c--------------------------------------------------------------------------
8726       subroutine transpose(n,a,at)
8727       implicit none
8728       integer n,i,j
8729       double precision a(n,n),at(n,n)
8730       do i=1,n
8731         do j=1,n
8732           at(j,i)=a(i,j)
8733         enddo
8734       enddo
8735       return
8736       end
8737 C---------------------------------------------------------------------------
8738       subroutine prodmat3(a1,a2,kk,transp,prod)
8739       implicit none
8740       integer i,j
8741       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8742       logical transp
8743 crc      double precision auxmat(2,2),prod_(2,2)
8744
8745       if (transp) then
8746 crc        call transpose2(kk(1,1),auxmat(1,1))
8747 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8748 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8749
8750            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8751      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8752            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8753      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8754            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8755      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8756            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8757      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8758
8759       else
8760 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8761 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8762
8763            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8764      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8765            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8766      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8767            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8768      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8769            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8770      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8771
8772       endif
8773 c      call transpose2(a2(1,1),a2t(1,1))
8774
8775 crc      print *,transp
8776 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8777 crc      print *,((prod(i,j),i=1,2),j=1,2)
8778
8779       return
8780       end
8781 C-----------------------------------------------------------------------------
8782       double precision function scalar(u,v)
8783       implicit none
8784       double precision u(3),v(3)
8785       double precision sc
8786       integer i
8787       sc=0.0d0
8788       do i=1,3
8789         sc=sc+u(i)*v(i)
8790       enddo
8791       scalar=sc
8792       return
8793       end
8794 C-----------------------------------------------------------------------
8795       double precision function sscale(r)
8796       double precision r,gamm
8797       include "COMMON.SPLITELE"
8798       if(r.lt.r_cut-rlamb) then
8799         sscale=1.0d0
8800       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8801         gamm=(r-(r_cut-rlamb))/rlamb
8802         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8803       else
8804         sscale=0d0
8805       endif
8806       return
8807       end
8808 C-----------------------------------------------------------------------
8809 C-----------------------------------------------------------------------
8810       double precision function sscagrad(r)
8811       double precision r,gamm
8812       include "COMMON.SPLITELE"
8813       if(r.lt.r_cut-rlamb) then
8814         sscagrad=0.0d0
8815       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8816         gamm=(r-(r_cut-rlamb))/rlamb
8817         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8818       else
8819         sscagrad=0.0d0
8820       endif
8821       return
8822       end
8823 C-----------------------------------------------------------------------
8824 C-----------------------------------------------------------------------
8825       double precision function sscalelip(r)
8826       double precision r,gamm
8827       include "COMMON.SPLITELE"
8828 C      if(r.lt.r_cut-rlamb) then
8829 C        sscale=1.0d0
8830 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8831 C        gamm=(r-(r_cut-rlamb))/rlamb
8832         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8833 C      else
8834 C        sscale=0d0
8835 C      endif
8836       return
8837       end
8838 C-----------------------------------------------------------------------
8839       double precision function sscagradlip(r)
8840       double precision r,gamm
8841       include "COMMON.SPLITELE"
8842 C     if(r.lt.r_cut-rlamb) then
8843 C        sscagrad=0.0d0
8844 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8845 C        gamm=(r-(r_cut-rlamb))/rlamb
8846         sscagradlip=r*(6*r-6.0d0)
8847 C      else
8848 C        sscagrad=0.0d0
8849 C      endif
8850       return
8851       end
8852
8853 C-----------------------------------------------------------------------
8854        subroutine set_shield_fac
8855       implicit real*8 (a-h,o-z)
8856       include 'DIMENSIONS'
8857       include 'COMMON.CHAIN'
8858       include 'COMMON.DERIV'
8859       include 'COMMON.IOUNITS'
8860       include 'COMMON.SHIELD'
8861       include 'COMMON.INTERACT'
8862 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8863       double precision div77_81/0.974996043d0/,
8864      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8865
8866 C the vector between center of side_chain and peptide group
8867        double precision pep_side(3),long,side_calf(3),
8868      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8869      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8870 C the line belowe needs to be changed for FGPROC>1
8871       do i=1,nres-1
8872       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8873       ishield_list(i)=0
8874 Cif there two consequtive dummy atoms there is no peptide group between them
8875 C the line below has to be changed for FGPROC>1
8876       VolumeTotal=0.0
8877       do k=1,nres
8878        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8879        dist_pep_side=0.0
8880        dist_side_calf=0.0
8881        do j=1,3
8882 C first lets set vector conecting the ithe side-chain with kth side-chain
8883       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8884 C      pep_side(j)=2.0d0
8885 C and vector conecting the side-chain with its proper calfa
8886       side_calf(j)=c(j,k+nres)-c(j,k)
8887 C      side_calf(j)=2.0d0
8888       pept_group(j)=c(j,i)-c(j,i+1)
8889 C lets have their lenght
8890       dist_pep_side=pep_side(j)**2+dist_pep_side
8891       dist_side_calf=dist_side_calf+side_calf(j)**2
8892       dist_pept_group=dist_pept_group+pept_group(j)**2
8893       enddo
8894        dist_pep_side=dsqrt(dist_pep_side)
8895        dist_pept_group=dsqrt(dist_pept_group)
8896        dist_side_calf=dsqrt(dist_side_calf)
8897       do j=1,3
8898         pep_side_norm(j)=pep_side(j)/dist_pep_side
8899         side_calf_norm(j)=dist_side_calf
8900       enddo
8901 C now sscale fraction
8902        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8903 C       print *,buff_shield,"buff"
8904 C now sscale
8905         if (sh_frac_dist.le.0.0) cycle
8906 C If we reach here it means that this side chain reaches the shielding sphere
8907 C Lets add him to the list for gradient
8908         ishield_list(i)=ishield_list(i)+1
8909 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8910 C this list is essential otherwise problem would be O3
8911         shield_list(ishield_list(i),i)=k
8912 C Lets have the sscale value
8913         if (sh_frac_dist.gt.1.0) then
8914          scale_fac_dist=1.0d0
8915          do j=1,3
8916          sh_frac_dist_grad(j)=0.0d0
8917          enddo
8918         else
8919          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8920      &                   *(2.0*sh_frac_dist-3.0d0)
8921          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8922      &                  /dist_pep_side/buff_shield*0.5
8923 C remember for the final gradient multiply sh_frac_dist_grad(j)
8924 C for side_chain by factor -2 !
8925          do j=1,3
8926          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8927 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8928 C     &                    sh_frac_dist_grad(j)
8929          enddo
8930         endif
8931 C        if ((i.eq.3).and.(k.eq.2)) then
8932 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8933 C     & ,"TU"
8934 C        endif
8935
8936 C this is what is now we have the distance scaling now volume...
8937       short=short_r_sidechain(itype(k))
8938       long=long_r_sidechain(itype(k))
8939       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8940 C now costhet_grad
8941 C       costhet=0.0d0
8942        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8943 C       costhet_fac=0.0d0
8944        do j=1,3
8945          costhet_grad(j)=costhet_fac*pep_side(j)
8946        enddo
8947 C remember for the final gradient multiply costhet_grad(j)
8948 C for side_chain by factor -2 !
8949 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8950 C pep_side0pept_group is vector multiplication
8951       pep_side0pept_group=0.0
8952       do j=1,3
8953       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8954       enddo
8955       cosalfa=(pep_side0pept_group/
8956      & (dist_pep_side*dist_side_calf))
8957       fac_alfa_sin=1.0-cosalfa**2
8958       fac_alfa_sin=dsqrt(fac_alfa_sin)
8959       rkprim=fac_alfa_sin*(long-short)+short
8960 C now costhet_grad
8961        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8962        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8963
8964        do j=1,3
8965          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8966      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8967      &*(long-short)/fac_alfa_sin*cosalfa/
8968      &((dist_pep_side*dist_side_calf))*
8969      &((side_calf(j))-cosalfa*
8970      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8971
8972         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8973      &*(long-short)/fac_alfa_sin*cosalfa
8974      &/((dist_pep_side*dist_side_calf))*
8975      &(pep_side(j)-
8976      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
8977        enddo
8978
8979       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
8980      &                    /VSolvSphere_div
8981      &                    *wshield
8982 C now the gradient...
8983 C grad_shield is gradient of Calfa for peptide groups
8984 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
8985 C     &               costhet,cosphi
8986 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
8987 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
8988       do j=1,3
8989       grad_shield(j,i)=grad_shield(j,i)
8990 C gradient po skalowaniu
8991      &                +(sh_frac_dist_grad(j)
8992 C  gradient po costhet
8993      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
8994      &-scale_fac_dist*(cosphi_grad_long(j))
8995      &/(1.0-cosphi) )*div77_81
8996      &*VofOverlap
8997 C grad_shield_side is Cbeta sidechain gradient
8998       grad_shield_side(j,ishield_list(i),i)=
8999      &        (sh_frac_dist_grad(j)*-2.0d0
9000      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9001      &       +scale_fac_dist*(cosphi_grad_long(j))
9002      &        *2.0d0/(1.0-cosphi))
9003      &        *div77_81*VofOverlap
9004
9005        grad_shield_loc(j,ishield_list(i),i)=
9006      &   scale_fac_dist*cosphi_grad_loc(j)
9007      &        *2.0d0/(1.0-cosphi)
9008      &        *div77_81*VofOverlap
9009       enddo
9010       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9011       enddo
9012       fac_shield(i)=VolumeTotal*div77_81+div4_81
9013 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9014       enddo
9015       return
9016       end
9017 C--------------------------------------------------------------------------
9018 C first for shielding is setting of function of side-chains
9019        subroutine set_shield_fac2
9020       implicit real*8 (a-h,o-z)
9021       include 'DIMENSIONS'
9022       include 'COMMON.CHAIN'
9023       include 'COMMON.DERIV'
9024       include 'COMMON.IOUNITS'
9025       include 'COMMON.SHIELD'
9026       include 'COMMON.INTERACT'
9027 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9028       double precision div77_81/0.974996043d0/,
9029      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9030
9031 C the vector between center of side_chain and peptide group
9032        double precision pep_side(3),long,side_calf(3),
9033      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9034      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9035 C the line belowe needs to be changed for FGPROC>1
9036       do i=1,nres-1
9037       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9038       ishield_list(i)=0
9039 Cif there two consequtive dummy atoms there is no peptide group between them
9040 C the line below has to be changed for FGPROC>1
9041       VolumeTotal=0.0
9042       do k=1,nres
9043        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9044        dist_pep_side=0.0
9045        dist_side_calf=0.0
9046        do j=1,3
9047 C first lets set vector conecting the ithe side-chain with kth side-chain
9048       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9049 C      pep_side(j)=2.0d0
9050 C and vector conecting the side-chain with its proper calfa
9051       side_calf(j)=c(j,k+nres)-c(j,k)
9052 C      side_calf(j)=2.0d0
9053       pept_group(j)=c(j,i)-c(j,i+1)
9054 C lets have their lenght
9055       dist_pep_side=pep_side(j)**2+dist_pep_side
9056       dist_side_calf=dist_side_calf+side_calf(j)**2
9057       dist_pept_group=dist_pept_group+pept_group(j)**2
9058       enddo
9059        dist_pep_side=dsqrt(dist_pep_side)
9060        dist_pept_group=dsqrt(dist_pept_group)
9061        dist_side_calf=dsqrt(dist_side_calf)
9062       do j=1,3
9063         pep_side_norm(j)=pep_side(j)/dist_pep_side
9064         side_calf_norm(j)=dist_side_calf
9065       enddo
9066 C now sscale fraction
9067        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9068 C       print *,buff_shield,"buff"
9069 C now sscale
9070         if (sh_frac_dist.le.0.0) cycle
9071 C If we reach here it means that this side chain reaches the shielding sphere
9072 C Lets add him to the list for gradient
9073         ishield_list(i)=ishield_list(i)+1
9074 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9075 C this list is essential otherwise problem would be O3
9076         shield_list(ishield_list(i),i)=k
9077 C Lets have the sscale value
9078         if (sh_frac_dist.gt.1.0) then
9079          scale_fac_dist=1.0d0
9080          do j=1,3
9081          sh_frac_dist_grad(j)=0.0d0
9082          enddo
9083         else
9084          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9085      &                   *(2.0d0*sh_frac_dist-3.0d0)
9086          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9087      &                  /dist_pep_side/buff_shield*0.5d0
9088 C remember for the final gradient multiply sh_frac_dist_grad(j)
9089 C for side_chain by factor -2 !
9090          do j=1,3
9091          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9092 C         sh_frac_dist_grad(j)=0.0d0
9093 C         scale_fac_dist=1.0d0
9094 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9095 C     &                    sh_frac_dist_grad(j)
9096          enddo
9097         endif
9098 C this is what is now we have the distance scaling now volume...
9099       short=short_r_sidechain(itype(k))
9100       long=long_r_sidechain(itype(k))
9101       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9102       sinthet=short/dist_pep_side*costhet
9103 C now costhet_grad
9104 C       costhet=0.6d0
9105 C       sinthet=0.8
9106        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9107 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9108 C     &             -short/dist_pep_side**2/costhet)
9109 C       costhet_fac=0.0d0
9110        do j=1,3
9111          costhet_grad(j)=costhet_fac*pep_side(j)
9112        enddo
9113 C remember for the final gradient multiply costhet_grad(j)
9114 C for side_chain by factor -2 !
9115 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9116 C pep_side0pept_group is vector multiplication
9117       pep_side0pept_group=0.0d0
9118       do j=1,3
9119       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9120       enddo
9121       cosalfa=(pep_side0pept_group/
9122      & (dist_pep_side*dist_side_calf))
9123       fac_alfa_sin=1.0d0-cosalfa**2
9124       fac_alfa_sin=dsqrt(fac_alfa_sin)
9125       rkprim=fac_alfa_sin*(long-short)+short
9126 C      rkprim=short
9127
9128 C now costhet_grad
9129        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9130 C       cosphi=0.6
9131        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9132        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9133      &      dist_pep_side**2)
9134 C       sinphi=0.8
9135        do j=1,3
9136          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9137      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9138      &*(long-short)/fac_alfa_sin*cosalfa/
9139      &((dist_pep_side*dist_side_calf))*
9140      &((side_calf(j))-cosalfa*
9141      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9142 C       cosphi_grad_long(j)=0.0d0
9143         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9144      &*(long-short)/fac_alfa_sin*cosalfa
9145      &/((dist_pep_side*dist_side_calf))*
9146      &(pep_side(j)-
9147      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9148 C       cosphi_grad_loc(j)=0.0d0
9149        enddo
9150 C      print *,sinphi,sinthet
9151       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9152      &                    /VSolvSphere_div
9153 C     &                    *wshield
9154 C now the gradient...
9155       do j=1,3
9156       grad_shield(j,i)=grad_shield(j,i)
9157 C gradient po skalowaniu
9158      &                +(sh_frac_dist_grad(j)*VofOverlap
9159 C  gradient po costhet
9160      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9161      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9162      &       sinphi/sinthet*costhet*costhet_grad(j)
9163      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9164      & )*wshield
9165 C grad_shield_side is Cbeta sidechain gradient
9166       grad_shield_side(j,ishield_list(i),i)=
9167      &        (sh_frac_dist_grad(j)*-2.0d0
9168      &        *VofOverlap
9169      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9170      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9171      &       sinphi/sinthet*costhet*costhet_grad(j)
9172      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9173      &       )*wshield
9174
9175        grad_shield_loc(j,ishield_list(i),i)=
9176      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9177      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9178      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9179      &        ))
9180      &        *wshield
9181       enddo
9182       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9183       enddo
9184       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9185 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9186 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9187       enddo
9188       return
9189       end
9190
9191 C-----------------------------------------------------------------------
9192 C-----------------------------------------------------------
9193 C This subroutine is to mimic the histone like structure but as well can be
9194 C utilizet to nanostructures (infinit) small modification has to be used to
9195 C make it finite (z gradient at the ends has to be changes as well as the x,y
9196 C gradient has to be modified at the ends
9197 C The energy function is Kihara potential
9198 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9199 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9200 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9201 C simple Kihara potential
9202       subroutine calctube(Etube)
9203        implicit real*8 (a-h,o-z)
9204       include 'DIMENSIONS'
9205       include 'COMMON.GEO'
9206       include 'COMMON.VAR'
9207       include 'COMMON.LOCAL'
9208       include 'COMMON.CHAIN'
9209       include 'COMMON.DERIV'
9210       include 'COMMON.NAMES'
9211       include 'COMMON.INTERACT'
9212       include 'COMMON.IOUNITS'
9213       include 'COMMON.CALC'
9214       include 'COMMON.CONTROL'
9215       include 'COMMON.SPLITELE'
9216       include 'COMMON.SBRIDGE'
9217       double precision tub_r,vectube(3),enetube(maxres*2)
9218       Etube=0.0d0
9219       do i=itube_start,itube_end
9220         enetube(i)=0.0d0
9221         enetube(i+nres)=0.0d0
9222       enddo
9223 C first we calculate the distance from tube center
9224 C first sugare-phosphate group for NARES this would be peptide group
9225 C for UNRES
9226        do i=itube_start,itube_end
9227 C lets ommit dummy atoms for now
9228        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9229 C now calculate distance from center of tube and direction vectors
9230       xmin=boxxsize
9231       ymin=boxysize
9232         do j=-1,1
9233          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9234          vectube(1)=vectube(1)+boxxsize*j
9235          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9236          vectube(2)=vectube(2)+boxysize*j
9237
9238          xminact=abs(vectube(1)-tubecenter(1))
9239          yminact=abs(vectube(2)-tubecenter(2))
9240            if (xmin.gt.xminact) then
9241             xmin=xminact
9242             xtemp=vectube(1)
9243            endif
9244            if (ymin.gt.yminact) then
9245              ymin=yminact
9246              ytemp=vectube(2)
9247             endif
9248          enddo
9249       vectube(1)=xtemp
9250       vectube(2)=ytemp
9251       vectube(1)=vectube(1)-tubecenter(1)
9252       vectube(2)=vectube(2)-tubecenter(2)
9253
9254 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9255 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9256
9257 C as the tube is infinity we do not calculate the Z-vector use of Z
9258 C as chosen axis
9259       vectube(3)=0.0d0
9260 C now calculte the distance
9261        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9262 C now normalize vector
9263       vectube(1)=vectube(1)/tub_r
9264       vectube(2)=vectube(2)/tub_r
9265 C calculte rdiffrence between r and r0
9266       rdiff=tub_r-tubeR0
9267 C and its 6 power
9268       rdiff6=rdiff**6.0d0
9269 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9270        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
9271 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9272 C       print *,rdiff,rdiff6,pep_aa_tube
9273 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9274 C now we calculate gradient
9275        fac=(-12.0d0*pep_aa_tube/rdiff6-
9276      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
9277 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9278 C     &rdiff,fac
9279
9280 C now direction of gg_tube vector
9281         do j=1,3
9282         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9283         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9284         enddo
9285         enddo
9286 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
9287 C        print *,gg_tube(1,0),"TU"
9288
9289
9290        do i=itube_start,itube_end
9291 C Lets not jump over memory as we use many times iti
9292          iti=itype(i)
9293 C lets ommit dummy atoms for now
9294          if ((iti.eq.ntyp1)
9295 C in UNRES uncomment the line below as GLY has no side-chain...
9296 C      .or.(iti.eq.10)
9297      &   ) cycle
9298       xmin=boxxsize
9299       ymin=boxysize
9300         do j=-1,1
9301          vectube(1)=mod((c(1,i+nres)),boxxsize)
9302          vectube(1)=vectube(1)+boxxsize*j
9303          vectube(2)=mod((c(2,i+nres)),boxysize)
9304          vectube(2)=vectube(2)+boxysize*j
9305
9306          xminact=abs(vectube(1)-tubecenter(1))
9307          yminact=abs(vectube(2)-tubecenter(2))
9308            if (xmin.gt.xminact) then
9309             xmin=xminact
9310             xtemp=vectube(1)
9311            endif
9312            if (ymin.gt.yminact) then
9313              ymin=yminact
9314              ytemp=vectube(2)
9315             endif
9316          enddo
9317       vectube(1)=xtemp
9318       vectube(2)=ytemp
9319 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
9320 C     &     tubecenter(2)
9321       vectube(1)=vectube(1)-tubecenter(1)
9322       vectube(2)=vectube(2)-tubecenter(2)
9323
9324 C as the tube is infinity we do not calculate the Z-vector use of Z
9325 C as chosen axis
9326       vectube(3)=0.0d0
9327 C now calculte the distance
9328        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9329 C now normalize vector
9330       vectube(1)=vectube(1)/tub_r
9331       vectube(2)=vectube(2)/tub_r
9332
9333 C calculte rdiffrence between r and r0
9334       rdiff=tub_r-tubeR0
9335 C and its 6 power
9336       rdiff6=rdiff**6.0d0
9337 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9338        sc_aa_tube=sc_aa_tube_par(iti)
9339        sc_bb_tube=sc_bb_tube_par(iti)
9340        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
9341 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9342 C now we calculate gradient
9343        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9344      &       6.0d0*sc_bb_tube/rdiff6/rdiff
9345 C now direction of gg_tube vector
9346          do j=1,3
9347           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9348           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9349          enddo
9350         enddo
9351         do i=itube_start,itube_end
9352           Etube=Etube+enetube(i)+enetube(i+nres)
9353         enddo
9354 C        print *,"ETUBE", etube
9355         return
9356         end
9357 C TO DO 1) add to total energy
9358 C       2) add to gradient summation
9359 C       3) add reading parameters (AND of course oppening of PARAM file)
9360 C       4) add reading the center of tube
9361 C       5) add COMMONs
9362 C       6) add to zerograd
9363
9364 C-----------------------------------------------------------------------
9365 C-----------------------------------------------------------
9366 C This subroutine is to mimic the histone like structure but as well can be
9367 C utilizet to nanostructures (infinit) small modification has to be used to
9368 C make it finite (z gradient at the ends has to be changes as well as the x,y
9369 C gradient has to be modified at the ends
9370 C The energy function is Kihara potential
9371 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9372 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9373 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9374 C simple Kihara potential
9375       subroutine calctube2(Etube)
9376        implicit real*8 (a-h,o-z)
9377       include 'DIMENSIONS'
9378       include 'COMMON.GEO'
9379       include 'COMMON.VAR'
9380       include 'COMMON.LOCAL'
9381       include 'COMMON.CHAIN'
9382       include 'COMMON.DERIV'
9383       include 'COMMON.NAMES'
9384       include 'COMMON.INTERACT'
9385       include 'COMMON.IOUNITS'
9386       include 'COMMON.CALC'
9387       include 'COMMON.CONTROL'
9388       include 'COMMON.SPLITELE'
9389       include 'COMMON.SBRIDGE'
9390       double precision tub_r,vectube(3),enetube(maxres*2)
9391       Etube=0.0d0
9392       do i=itube_start,itube_end
9393         enetube(i)=0.0d0
9394         enetube(i+nres)=0.0d0
9395       enddo
9396 C first we calculate the distance from tube center
9397 C first sugare-phosphate group for NARES this would be peptide group
9398 C for UNRES
9399        do i=itube_start,itube_end
9400 C lets ommit dummy atoms for now
9401
9402        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9403 C now calculate distance from center of tube and direction vectors
9404 C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9405 C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
9406 C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9407 C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
9408       xmin=boxxsize
9409       ymin=boxysize
9410         do j=-1,1
9411          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9412          vectube(1)=vectube(1)+boxxsize*j
9413          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9414          vectube(2)=vectube(2)+boxysize*j
9415
9416          xminact=abs(vectube(1)-tubecenter(1))
9417          yminact=abs(vectube(2)-tubecenter(2))
9418            if (xmin.gt.xminact) then
9419             xmin=xminact
9420             xtemp=vectube(1)
9421            endif
9422            if (ymin.gt.yminact) then
9423              ymin=yminact
9424              ytemp=vectube(2)
9425             endif
9426          enddo
9427       vectube(1)=xtemp
9428       vectube(2)=ytemp
9429       vectube(1)=vectube(1)-tubecenter(1)
9430       vectube(2)=vectube(2)-tubecenter(2)
9431
9432 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9433 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9434
9435 C as the tube is infinity we do not calculate the Z-vector use of Z
9436 C as chosen axis
9437       vectube(3)=0.0d0
9438 C now calculte the distance
9439        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9440 C now normalize vector
9441       vectube(1)=vectube(1)/tub_r
9442       vectube(2)=vectube(2)/tub_r
9443 C calculte rdiffrence between r and r0
9444       rdiff=tub_r-tubeR0
9445 C and its 6 power
9446       rdiff6=rdiff**6.0d0
9447 C THIS FRAGMENT MAKES TUBE FINITE
9448         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
9449         if (positi.le.0) positi=positi+boxzsize
9450 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9451 c for each residue check if it is in lipid or lipid water border area
9452 C       respos=mod(c(3,i+nres),boxzsize)
9453        print *,positi,bordtubebot,buftubebot,bordtubetop
9454        if ((positi.gt.bordtubebot)
9455      & .and.(positi.lt.bordtubetop)) then
9456 C the energy transfer exist
9457         if (positi.lt.buftubebot) then
9458          fracinbuf=1.0d0-
9459      &     ((positi-bordtubebot)/tubebufthick)
9460 C lipbufthick is thickenes of lipid buffore
9461          sstube=sscalelip(fracinbuf)
9462          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
9463          print *,ssgradtube, sstube,tubetranene(itype(i))
9464          enetube(i)=enetube(i)+sstube*tubetranenepep
9465 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9466 C     &+ssgradtube*tubetranene(itype(i))
9467 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9468 C     &+ssgradtube*tubetranene(itype(i))
9469 C         print *,"doing sccale for lower part"
9470         elseif (positi.gt.buftubetop) then
9471          fracinbuf=1.0d0-
9472      &((bordtubetop-positi)/tubebufthick)
9473          sstube=sscalelip(fracinbuf)
9474          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
9475          enetube(i)=enetube(i)+sstube*tubetranenepep
9476 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9477 C     &+ssgradtube*tubetranene(itype(i))
9478 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9479 C     &+ssgradtube*tubetranene(itype(i))
9480 C          print *, "doing sscalefor top part",sslip,fracinbuf
9481         else
9482          sstube=1.0d0
9483          ssgradtube=0.0d0
9484          enetube(i)=enetube(i)+sstube*tubetranenepep
9485 C         print *,"I am in true lipid"
9486         endif
9487         else
9488 C          sstube=0.0d0
9489 C          ssgradtube=0.0d0
9490         cycle
9491         endif ! if in lipid or buffor
9492
9493 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9494        enetube(i)=enetube(i)+sstube*
9495      &(pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
9496 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9497 C       print *,rdiff,rdiff6,pep_aa_tube
9498 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9499 C now we calculate gradient
9500        fac=(-12.0d0*pep_aa_tube/rdiff6-
9501      &       6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
9502 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9503 C     &rdiff,fac
9504
9505 C now direction of gg_tube vector
9506         do j=1,3
9507         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9508         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9509         enddo
9510          gg_tube(3,i)=gg_tube(3,i)
9511      &+ssgradtube*enetube(i)/sstube/2.0d0
9512          gg_tube(3,i-1)= gg_tube(3,i-1)
9513      &+ssgradtube*enetube(i)/sstube/2.0d0
9514
9515         enddo
9516 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
9517 C        print *,gg_tube(1,0),"TU"
9518         do i=itube_start,itube_end
9519 C Lets not jump over memory as we use many times iti
9520          iti=itype(i)
9521 C lets ommit dummy atoms for now
9522          if ((iti.eq.ntyp1)
9523 C in UNRES uncomment the line below as GLY has no side-chain...
9524      &      .or.(iti.eq.10)
9525      &   ) cycle
9526           vectube(1)=c(1,i+nres)
9527           vectube(1)=mod(vectube(1),boxxsize)
9528           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
9529           vectube(2)=c(2,i+nres)
9530           vectube(2)=mod(vectube(2),boxysize)
9531           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
9532
9533       vectube(1)=vectube(1)-tubecenter(1)
9534       vectube(2)=vectube(2)-tubecenter(2)
9535 C THIS FRAGMENT MAKES TUBE FINITE
9536         positi=(mod(c(3,i+nres),boxzsize))
9537         if (positi.le.0) positi=positi+boxzsize
9538 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9539 c for each residue check if it is in lipid or lipid water border area
9540 C       respos=mod(c(3,i+nres),boxzsize)
9541        print *,positi,bordtubebot,buftubebot,bordtubetop
9542        if ((positi.gt.bordtubebot)
9543      & .and.(positi.lt.bordtubetop)) then
9544 C the energy transfer exist
9545         if (positi.lt.buftubebot) then
9546          fracinbuf=1.0d0-
9547      &     ((positi-bordtubebot)/tubebufthick)
9548 C lipbufthick is thickenes of lipid buffore
9549          sstube=sscalelip(fracinbuf)
9550          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
9551          print *,ssgradtube, sstube,tubetranene(itype(i))
9552          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9553 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9554 C     &+ssgradtube*tubetranene(itype(i))
9555 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9556 C     &+ssgradtube*tubetranene(itype(i))
9557 C         print *,"doing sccale for lower part"
9558         elseif (positi.gt.buftubetop) then
9559          fracinbuf=1.0d0-
9560      &((bordtubetop-positi)/tubebufthick)
9561          sstube=sscalelip(fracinbuf)
9562          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
9563          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9564 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9565 C     &+ssgradtube*tubetranene(itype(i))
9566 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9567 C     &+ssgradtube*tubetranene(itype(i))
9568 C          print *, "doing sscalefor top part",sslip,fracinbuf
9569         else
9570          sstube=1.0d0
9571          ssgradtube=0.0d0
9572          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9573 C         print *,"I am in true lipid"
9574         endif
9575         else
9576 C          sstube=0.0d0
9577 C          ssgradtube=0.0d0
9578         cycle
9579         endif ! if in lipid or buffor
9580 CEND OF FINITE FRAGMENT
9581 C as the tube is infinity we do not calculate the Z-vector use of Z
9582 C as chosen axis
9583       vectube(3)=0.0d0
9584 C now calculte the distance
9585        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9586 C now normalize vector
9587       vectube(1)=vectube(1)/tub_r
9588       vectube(2)=vectube(2)/tub_r
9589 C calculte rdiffrence between r and r0
9590       rdiff=tub_r-tubeR0
9591 C and its 6 power
9592       rdiff6=rdiff**6.0d0
9593 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9594        sc_aa_tube=sc_aa_tube_par(iti)
9595        sc_bb_tube=sc_bb_tube_par(iti)
9596        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
9597      &                 *sstube+enetube(i+nres)
9598 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9599 C now we calculate gradient
9600        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9601      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
9602 C now direction of gg_tube vector
9603          do j=1,3
9604           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9605           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9606          enddo
9607          gg_tube_SC(3,i)=gg_tube_SC(3,i)
9608      &+ssgradtube*enetube(i+nres)/sstube
9609          gg_tube(3,i-1)= gg_tube(3,i-1)
9610      &+ssgradtube*enetube(i+nres)/sstube
9611
9612         enddo
9613         do i=itube_start,itube_end
9614           Etube=Etube+enetube(i)+enetube(i+nres)
9615         enddo
9616 C        print *,"ETUBE", etube
9617         return
9618         end
9619 C TO DO 1) add to total energy
9620 C       2) add to gradient summation
9621 C       3) add reading parameters (AND of course oppening of PARAM file)
9622 C       4) add reading the center of tube
9623 C       5) add COMMONs
9624 C       6) add to zerograd
9625
9626
9627 C#-------------------------------------------------------------------------------
9628 C This subroutine is to mimic the histone like structure but as well can be
9629 C utilizet to nanostructures (infinit) small modification has to be used to
9630 C make it finite (z gradient at the ends has to be changes as well as the x,y
9631 C gradient has to be modified at the ends
9632 C The energy function is Kihara potential
9633 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9634 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9635 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9636 C simple Kihara potential
9637       subroutine calcnano(Etube)
9638        implicit real*8 (a-h,o-z)
9639       include 'DIMENSIONS'
9640       include 'COMMON.GEO'
9641       include 'COMMON.VAR'
9642       include 'COMMON.LOCAL'
9643       include 'COMMON.CHAIN'
9644       include 'COMMON.DERIV'
9645       include 'COMMON.NAMES'
9646       include 'COMMON.INTERACT'
9647       include 'COMMON.IOUNITS'
9648       include 'COMMON.CALC'
9649       include 'COMMON.CONTROL'
9650       include 'COMMON.SPLITELE'
9651       include 'COMMON.SBRIDGE'
9652       double precision tub_r,vectube(3),enetube(maxres*2),
9653      & enecavtube(maxres*2)
9654       Etube=0.0d0
9655       do i=itube_start,itube_end
9656         enetube(i)=0.0d0
9657         enetube(i+nres)=0.0d0
9658       enddo
9659 C first we calculate the distance from tube center
9660 C first sugare-phosphate group for NARES this would be peptide group
9661 C for UNRES
9662        do i=itube_start,itube_end
9663 C lets ommit dummy atoms for now
9664        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9665 C now calculate distance from center of tube and direction vectors
9666       xmin=boxxsize
9667       ymin=boxysize
9668       zmin=boxzsize
9669
9670         do j=-1,1
9671          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9672          vectube(1)=vectube(1)+boxxsize*j
9673          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9674          vectube(2)=vectube(2)+boxysize*j
9675          vectube(3)=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
9676          vectube(3)=vectube(3)+boxzsize*j
9677
9678
9679          xminact=abs(vectube(1)-tubecenter(1))
9680          yminact=abs(vectube(2)-tubecenter(2))
9681          zminact=abs(vectube(3)-tubecenter(3))
9682
9683            if (xmin.gt.xminact) then
9684             xmin=xminact
9685             xtemp=vectube(1)
9686            endif
9687            if (ymin.gt.yminact) then
9688              ymin=yminact
9689              ytemp=vectube(2)
9690             endif
9691            if (zmin.gt.zminact) then
9692              zmin=zminact
9693              ztemp=vectube(3)
9694             endif
9695          enddo
9696       vectube(1)=xtemp
9697       vectube(2)=ytemp
9698       vectube(3)=ztemp
9699
9700       vectube(1)=vectube(1)-tubecenter(1)
9701       vectube(2)=vectube(2)-tubecenter(2)
9702       vectube(3)=vectube(3)-tubecenter(3)
9703
9704 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9705 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9706 C as the tube is infinity we do not calculate the Z-vector use of Z
9707 C as chosen axis
9708 C      vectube(3)=0.0d0
9709 C now calculte the distance
9710        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9711 C now normalize vector
9712       vectube(1)=vectube(1)/tub_r
9713       vectube(2)=vectube(2)/tub_r
9714       vectube(3)=vectube(3)/tub_r
9715 C calculte rdiffrence between r and r0
9716       rdiff=tub_r-tubeR0
9717 C and its 6 power
9718       rdiff6=rdiff**6.0d0
9719 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9720        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
9721 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9722 C       print *,rdiff,rdiff6,pep_aa_tube
9723 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9724 C now we calculate gradient
9725        fac=(-12.0d0*pep_aa_tube/rdiff6-
9726      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
9727 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9728 C     &rdiff,fac
9729          if (acavtubpep.eq.0.0d0) then
9730 C go to 667
9731          enecavtube(i)=0.0
9732          faccav=0.0
9733          else
9734          denominator=(1.0+dcavtubpep*rdiff6*rdiff6)
9735          enecavtube(i)=
9736      &   (bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)+ccavtubpep)
9737      &   /denominator
9738          enecavtube(i)=0.0
9739          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/sqrt(rdiff))
9740      &   *denominator-(bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)
9741      &   +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)
9742      &   /denominator**2.0d0
9743 C         faccav=0.0
9744 C         fac=fac+faccav
9745 C 667     continue
9746          endif
9747 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtubpep,denominator,
9748 C     &   enecavtube(i),faccav
9749 C         print *,"licz=",
9750 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9751 CX         print *,"finene=",enetube(i+nres)+enecavtube(i)
9752
9753 C now direction of gg_tube vector
9754         do j=1,3
9755         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9756         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9757         enddo
9758         enddo
9759
9760        do i=itube_start,itube_end
9761         enecavtube(i)=0.0
9762 C Lets not jump over memory as we use many times iti
9763          iti=itype(i)
9764 C lets ommit dummy atoms for now
9765          if ((iti.eq.ntyp1)
9766 C in UNRES uncomment the line below as GLY has no side-chain...
9767 C      .or.(iti.eq.10)
9768      &   ) cycle
9769       xmin=boxxsize
9770       ymin=boxysize
9771       zmin=boxzsize
9772         do j=-1,1
9773          vectube(1)=mod((c(1,i+nres)),boxxsize)
9774          vectube(1)=vectube(1)+boxxsize*j
9775          vectube(2)=mod((c(2,i+nres)),boxysize)
9776          vectube(2)=vectube(2)+boxysize*j
9777          vectube(3)=mod((c(3,i+nres)),boxzsize)
9778          vectube(3)=vectube(3)+boxzsize*j
9779
9780
9781          xminact=abs(vectube(1)-tubecenter(1))
9782          yminact=abs(vectube(2)-tubecenter(2))
9783          zminact=abs(vectube(3)-tubecenter(3))
9784
9785            if (xmin.gt.xminact) then
9786             xmin=xminact
9787             xtemp=vectube(1)
9788            endif
9789            if (ymin.gt.yminact) then
9790              ymin=yminact
9791              ytemp=vectube(2)
9792             endif
9793            if (zmin.gt.zminact) then
9794              zmin=zminact
9795              ztemp=vectube(3)
9796             endif
9797          enddo
9798       vectube(1)=xtemp
9799       vectube(2)=ytemp
9800       vectube(3)=ztemp
9801
9802 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
9803 C     &     tubecenter(2)
9804       vectube(1)=vectube(1)-tubecenter(1)
9805       vectube(2)=vectube(2)-tubecenter(2)
9806       vectube(3)=vectube(3)-tubecenter(3)
9807 C now calculte the distance
9808        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9809 C now normalize vector
9810       vectube(1)=vectube(1)/tub_r
9811       vectube(2)=vectube(2)/tub_r
9812       vectube(3)=vectube(3)/tub_r
9813
9814 C calculte rdiffrence between r and r0
9815       rdiff=tub_r-tubeR0
9816 C and its 6 power
9817       rdiff6=rdiff**6.0d0
9818 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9819        sc_aa_tube=sc_aa_tube_par(iti)
9820        sc_bb_tube=sc_bb_tube_par(iti)
9821        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
9822 C       enetube(i+nres)=0.0d0
9823 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9824 C now we calculate gradient
9825        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9826      &       6.0d0*sc_bb_tube/rdiff6/rdiff
9827 C       fac=0.0
9828 C now direction of gg_tube vector
9829 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
9830          if (acavtub(iti).eq.0.0d0) then
9831 C go to 667
9832          enecavtube(i+nres)=0.0
9833          faccav=0.0
9834          else
9835          denominator=(1.0+dcavtub(iti)*rdiff6*rdiff6)
9836          enecavtube(i+nres)=
9837      &   (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9838      &   /denominator
9839 C         enecavtube(i)=0.0
9840          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/sqrt(rdiff))
9841      &   *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)
9842      &   +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)
9843      &   /denominator**2.0d0
9844 C         faccav=0.0
9845          fac=fac+faccav
9846 C 667     continue
9847          endif
9848 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
9849 C     &   enecavtube(i),faccav
9850 C         print *,"licz=",
9851 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9852 C         print *,"finene=",enetube(i+nres)+enecavtube(i)
9853          do j=1,3
9854           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9855           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9856          enddo
9857         enddo
9858 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
9859 C        do i=itube_start,itube_end
9860 C        enecav(i)=0.0
9861 C        iti=itype(i)
9862 C        if (acavtub(iti).eq.0.0) cycle
9863
9864
9865
9866         do i=itube_start,itube_end
9867           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i)
9868      & +enecavtube(i+nres)
9869         enddo
9870 C        print *,"ETUBE", etube
9871         return
9872         end
9873 C TO DO 1) add to total energy
9874 C       2) add to gradient summation
9875 C       3) add reading parameters (AND of course oppening of PARAM file)
9876 C       4) add reading the center of tube
9877 C       5) add COMMONs
9878 C       6) add to zerograd
9879