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       if (TUBElog.eq.1) then
 108       print *,"just before call"
 109         call calctube(Etube)
 110        print *,"just after call",etube
 111        elseif (TUBElog.eq.2) then
 112         call calctube2(Etube)
 113        elseif (TUBElog.eq.3) then
 114         call calcnano(Etube)
 115        else
 116        Etube=0.0d0
 117        endif
 118
 119 C
 120 C 12/1/95 Multi-body terms
 121 C
 122       n_corr=0
 123       n_corr1=0
 124       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 125      &    .or. wturn6.gt.0.0d0) then
 126 c         print *,"calling multibody_eello"
 127          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 128 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 129 c         print *,ecorr,ecorr5,ecorr6,eturn6
 130       else
 131          ecorr=0.0d0
 132          ecorr5=0.0d0
 133          ecorr6=0.0d0
 134          eturn6=0.0d0
 135       endif
 136       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 137          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 138       endif
 139 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 140 #ifdef SPLITELE
 141       if (shield_mode.gt.0) then
 142       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 143      & +welec*fact(1)*ees
 144      & +fact(1)*wvdwpp*evdw1
 145      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 146      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 147      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 148      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 149      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 150      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 151      & +wliptran*eliptran+wtube*Etube
 152       else
 153       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 154      & +wvdwpp*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+wtube*Etube
 162       endif
 163 #else
 164       if (shield_mode.gt.0) then
 165       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 166      & +welec*fact(1)*(ees+evdw1)
 167      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 168      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 169      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 170      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 171      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 172      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 173      & +wliptran*eliptran+wtube*Etube
 174       else
 175       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 176      & +welec*fact(1)*(ees+evdw1)
 177      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 178      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 179      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 180      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 181      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 182      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 183      & +wliptran*eliptran+wtube*Etube
 184       endif
 185 #endif
 186       energia(0)=etot
 187       energia(1)=evdw
 188 #ifdef SCP14
 189       energia(2)=evdw2-evdw2_14
 190       energia(17)=evdw2_14
 191 #else
 192       energia(2)=evdw2
 193       energia(17)=0.0d0
 194 #endif
 195 #ifdef SPLITELE
 196       energia(3)=ees
 197       energia(16)=evdw1
 198 #else
 199       energia(3)=ees+evdw1
 200       energia(16)=0.0d0
 201 #endif
 202       energia(4)=ecorr
 203       energia(5)=ecorr5
 204       energia(6)=ecorr6
 205       energia(7)=eel_loc
 206       energia(8)=eello_turn3
 207       energia(9)=eello_turn4
 208       energia(10)=eturn6
 209       energia(11)=ebe
 210       energia(12)=escloc
 211       energia(13)=etors
 212       energia(14)=etors_d
 213       energia(15)=ehpb
 214       energia(18)=estr
 215       energia(19)=esccor
 216       energia(20)=edihcnstr
 217       energia(21)=evdw_t
 218       energia(24)=ethetacnstr
 219       energia(22)=eliptran
 220       energia(25)=Etube
 221 c detecting NaNQ
 222 #ifdef ISNAN
 223 #ifdef AIX
 224       if (isnan(etot).ne.0) energia(0)=1.0d+99
 225 #else
 226       if (isnan(etot)) energia(0)=1.0d+99
 227 #endif
 228 #else
 229       i=0
 230 #ifdef WINPGI
 231       idumm=proc_proc(etot,i)
 232 #else
 233       call proc_proc(etot,i)
 234 #endif
 235       if(i.eq.1)energia(0)=1.0d+99
 236 #endif
 237 #ifdef MPL
 238 c     endif
 239 #endif
 240 #define DEBUG
 241 #ifdef DEBUG
 242       call enerprint(energia,fact)
 243 #endif
 244 #undef DEBUG
 245       if (calc_grad) then
 246 C
 247 C Sum up the components of the Cartesian gradient.
 248 C
 249 #ifdef SPLITELE
 250       do i=1,nct
 251         do j=1,3
 252       if (shield_mode.eq.0) then
 253           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 254      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 255      &                wbond*gradb(j,i)+
 256      &                wstrain*ghpbc(j,i)+
 257      &                wcorr*fact(3)*gradcorr(j,i)+
 258      &                wel_loc*fact(2)*gel_loc(j,i)+
 259      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 260      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 261      &                wcorr5*fact(4)*gradcorr5(j,i)+
 262      &                wcorr6*fact(5)*gradcorr6(j,i)+
 263      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 264      &                wsccor*fact(2)*gsccorc(j,i)
 265      &               +wliptran*gliptranc(j,i)
 266      &                 +welec*gshieldc(j,i)
 267      &                 +welec*gshieldc_loc(j,i)
 268      &                 +wcorr*gshieldc_ec(j,i)
 269      &                 +wcorr*gshieldc_loc_ec(j,i)
 270      &                 +wturn3*gshieldc_t3(j,i)
 271      &                 +wturn3*gshieldc_loc_t3(j,i)
 272      &                 +wturn4*gshieldc_t4(j,i)
 273      &                 +wturn4*gshieldc_loc_t4(j,i)
 274      &                 +wel_loc*gshieldc_ll(j,i)
 275      &                 +wel_loc*gshieldc_loc_ll(j,i)
 276      &                +wtube*gg_tube(j,i)
 277
 278
 279           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 280      &                  wbond*gradbx(j,i)+
 281      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 282      &                  wsccor*fact(2)*gsccorx(j,i)
 283      &                 +wliptran*gliptranx(j,i)
 284      &                 +welec*gshieldx(j,i)
 285      &                 +wcorr*gshieldx_ec(j,i)
 286      &                 +wturn3*gshieldx_t3(j,i)
 287      &                 +wturn4*gshieldx_t4(j,i)
 288      &                 +wel_loc*gshieldx_ll(j,i)
 289
 290         else
 291           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 292      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 293      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 294      &                wbond*gradb(j,i)+
 295      &                wstrain*ghpbc(j,i)+
 296      &                wcorr*fact(3)*gradcorr(j,i)+
 297      &                wel_loc*fact(2)*gel_loc(j,i)+
 298      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 299      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 300      &                wcorr5*fact(4)*gradcorr5(j,i)+
 301      &                wcorr6*fact(5)*gradcorr6(j,i)+
 302      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 303      &                wsccor*fact(2)*gsccorc(j,i)
 304      &               +wliptran*gliptranc(j,i)
 305      &                 +welec*gshieldc(j,i)
 306      &                 +welec*gshieldc_loc(j,i)
 307      &                 +wcorr*gshieldc_ec(j,i)
 308      &                 +wcorr*gshieldc_loc_ec(j,i)
 309      &                 +wturn3*gshieldc_t3(j,i)
 310      &                 +wturn3*gshieldc_loc_t3(j,i)
 311      &                 +wturn4*gshieldc_t4(j,i)
 312      &                 +wturn4*gshieldc_loc_t4(j,i)
 313      &                 +wel_loc*gshieldc_ll(j,i)
 314      &                 +wel_loc*gshieldc_loc_ll(j,i)
 315      &                +wtube*gg_tube(j,i)
 316
 317
 318           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 319      &                 +fact(1)*wscp*gradx_scp(j,i)+
 320      &                  wbond*gradbx(j,i)+
 321      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 322      &                  wsccor*fact(2)*gsccorx(j,i)
 323      &                 +wliptran*gliptranx(j,i)
 324      &                 +welec*gshieldx(j,i)
 325      &                 +wcorr*gshieldx_ec(j,i)
 326      &                 +wturn3*gshieldx_t3(j,i)
 327      &                 +wturn4*gshieldx_t4(j,i)
 328      &                 +wel_loc*gshieldx_ll(j,i)
 329
 330
 331         endif
 332         enddo
 333 #else
 334       do i=1,nct
 335         do j=1,3
 336                 if (shield_mode.eq.0) then
 337           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 338      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 339      &                wbond*gradb(j,i)+
 340      &                wcorr*fact(3)*gradcorr(j,i)+
 341      &                wel_loc*fact(2)*gel_loc(j,i)+
 342      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 343      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 344      &                wcorr5*fact(4)*gradcorr5(j,i)+
 345      &                wcorr6*fact(5)*gradcorr6(j,i)+
 346      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 347      &                wsccor*fact(2)*gsccorc(j,i)
 348      &               +wliptran*gliptranc(j,i)
 349      &                 +welec*gshieldc(j,i)
 350      &                 +welec*gshieldc_loc(j,i)
 351      &                 +wcorr*gshieldc_ec(j,i)
 352      &                 +wcorr*gshieldc_loc_ec(j,i)
 353      &                 +wturn3*gshieldc_t3(j,i)
 354      &                 +wturn3*gshieldc_loc_t3(j,i)
 355      &                 +wturn4*gshieldc_t4(j,i)
 356      &                 +wturn4*gshieldc_loc_t4(j,i)
 357      &                 +wel_loc*gshieldc_ll(j,i)
 358      &                 +wel_loc*gshieldc_loc_ll(j,i)
 359
 360           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 361      &                  wbond*gradbx(j,i)+
 362      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 363      &                  wsccor*fact(1)*gsccorx(j,i)
 364      &                 +wliptran*gliptranx(j,i)
 365      &                 +welec*gshieldx(j,i)
 366      &                 +wcorr*gshieldx_ec(j,i)
 367      &                 +wturn3*gshieldx_t3(j,i)
 368      &                 +wturn4*gshieldx_t4(j,i)
 369      &                 +wel_loc*gshieldx_ll(j,i)
 370      &                 +wtube*gg_tube_sc(j,i)
 371
 372
 373               else
 374           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 375      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 376      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 377      &                wbond*gradb(j,i)+
 378      &                wcorr*fact(3)*gradcorr(j,i)+
 379      &                wel_loc*fact(2)*gel_loc(j,i)+
 380      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 381      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 382      &                wcorr5*fact(4)*gradcorr5(j,i)+
 383      &                wcorr6*fact(5)*gradcorr6(j,i)+
 384      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 385      &                wsccor*fact(2)*gsccorc(j,i)
 386      &               +wliptran*gliptranc(j,i)
 387      &                 +welec*gshieldc(j,i)
 388      &                 +welec*gshieldc_loc(j,i)
 389      &                 +wcorr*gshieldc_ec(j,i)
 390      &                 +wcorr*gshieldc_loc_ec(j,i)
 391      &                 +wturn3*gshieldc_t3(j,i)
 392      &                 +wturn3*gshieldc_loc_t3(j,i)
 393      &                 +wturn4*gshieldc_t4(j,i)
 394      &                 +wturn4*gshieldc_loc_t4(j,i)
 395      &                 +wel_loc*gshieldc_ll(j,i)
 396      &                 +wel_loc*gshieldc_loc_ll(j,i)
 397
 398           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 399      &                  fact(1)*wscp*gradx_scp(j,i)+
 400      &                  wbond*gradbx(j,i)+
 401      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 402      &                  wsccor*fact(1)*gsccorx(j,i)
 403      &                 +wliptran*gliptranx(j,i)
 404      &                 +welec*gshieldx(j,i)
 405      &                 +wcorr*gshieldx_ec(j,i)
 406      &                 +wturn3*gshieldx_t3(j,i)
 407      &                 +wturn4*gshieldx_t4(j,i)
 408      &                 +wel_loc*gshieldx_ll(j,i)
 409      &                 +wtube*gg_tube_sc(j,i)
 410
 411
 412          endif
 413         enddo
 414 #endif
 415       enddo
 416
 417
 418       do i=1,nres-3
 419         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 420      &   +wcorr5*fact(4)*g_corr5_loc(i)
 421      &   +wcorr6*fact(5)*g_corr6_loc(i)
 422      &   +wturn4*fact(3)*gel_loc_turn4(i)
 423      &   +wturn3*fact(2)*gel_loc_turn3(i)
 424      &   +wturn6*fact(5)*gel_loc_turn6(i)
 425      &   +wel_loc*fact(2)*gel_loc_loc(i)
 426 c     &   +wsccor*fact(1)*gsccor_loc(i)
 427 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 428       enddo
 429       endif
 430       if (dyn_ss) call dyn_set_nss
 431       return
 432       end
 433 C------------------------------------------------------------------------
 434       subroutine enerprint(energia,fact)
 435       implicit real*8 (a-h,o-z)
 436       include 'DIMENSIONS'
 437       include 'DIMENSIONS.ZSCOPT'
 438       include 'COMMON.IOUNITS'
 439       include 'COMMON.FFIELD'
 440       include 'COMMON.SBRIDGE'
 441       double precision energia(0:max_ene),fact(6)
 442       etot=energia(0)
 443       evdw=energia(1)+fact(6)*energia(21)
 444 #ifdef SCP14
 445       evdw2=energia(2)+energia(17)
 446 #else
 447       evdw2=energia(2)
 448 #endif
 449       ees=energia(3)
 450 #ifdef SPLITELE
 451       evdw1=energia(16)
 452 #endif
 453       ecorr=energia(4)
 454       ecorr5=energia(5)
 455       ecorr6=energia(6)
 456       eel_loc=energia(7)
 457       eello_turn3=energia(8)
 458       eello_turn4=energia(9)
 459       eello_turn6=energia(10)
 460       ebe=energia(11)
 461       escloc=energia(12)
 462       etors=energia(13)
 463       etors_d=energia(14)
 464       ehpb=energia(15)
 465       esccor=energia(19)
 466       edihcnstr=energia(20)
 467       estr=energia(18)
 468       ethetacnstr=energia(24)
 469       eliptran=energia(22)
 470       Etube=energia(25)
 471 #ifdef SPLITELE
 472       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 473      &  wvdwpp,
 474      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 475      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 476      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 477      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 478      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 479      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 480      & eliptran,wliptran,etube,wtube ,etot
 481    10 format (/'Virtual-chain energies:'//
 482      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 483      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 484      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 485      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 486      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 487      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 488      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 489      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 490      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 491      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 492      & ' (SS bridges & dist. cnstr.)'/
 493      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 494      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 495      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 496      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 497      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 498      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 499      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 500      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 501      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 502      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 503      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 504      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 505      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 506      & 'ETOT=  ',1pE16.6,' (total)')
 507 #else
 508       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 509      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 510      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 511      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 512      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 513      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 514      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etube,wtube,etot
 515    10 format (/'Virtual-chain energies:'//
 516      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 517      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 518      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 519      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 520      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 521      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 522      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 523      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 524      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 525      & ' (SS bridges & dist. cnstr.)'/
 526      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 527      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 528      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 529      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 530      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 531      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 532      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 533      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 534      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 535      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 536      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 537      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 538      & 'ETOT=  ',1pE16.6,' (total)')
 539 #endif
 540       return
 541       end
 542 C-----------------------------------------------------------------------
 543       subroutine elj(evdw,evdw_t)
 544 C
 545 C This subroutine calculates the interaction energy of nonbonded side chains
 546 C assuming the LJ potential of interaction.
 547 C
 548       implicit real*8 (a-h,o-z)
 549       include 'DIMENSIONS'
 550       include 'DIMENSIONS.ZSCOPT'
 551       include "DIMENSIONS.COMPAR"
 552       parameter (accur=1.0d-10)
 553       include 'COMMON.GEO'
 554       include 'COMMON.VAR'
 555       include 'COMMON.LOCAL'
 556       include 'COMMON.CHAIN'
 557       include 'COMMON.DERIV'
 558       include 'COMMON.INTERACT'
 559       include 'COMMON.TORSION'
 560       include 'COMMON.ENEPS'
 561       include 'COMMON.SBRIDGE'
 562       include 'COMMON.NAMES'
 563       include 'COMMON.IOUNITS'
 564       include 'COMMON.CONTACTS'
 565       dimension gg(3)
 566       integer icant
 567       external icant
 568 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 569 c ROZNICA z cluster
 570       do i=1,210
 571         do j=1,2
 572           eneps_temp(j,i)=0.0d0
 573         enddo
 574       enddo
 575 cROZNICA
 576
 577       evdw=0.0D0
 578       evdw_t=0.0d0
 579       do i=iatsc_s,iatsc_e
 580         itypi=iabs(itype(i))
 581         if (itypi.eq.ntyp1) cycle
 582         itypi1=iabs(itype(i+1))
 583         xi=c(1,nres+i)
 584         yi=c(2,nres+i)
 585         zi=c(3,nres+i)
 586 C Change 12/1/95
 587         num_conti=0
 588 C
 589 C Calculate SC interaction energy.
 590 C
 591         do iint=1,nint_gr(i)
 592 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 593 cd   &                  'iend=',iend(i,iint)
 594           do j=istart(i,iint),iend(i,iint)
 595             itypj=iabs(itype(j))
 596             if (itypj.eq.ntyp1) cycle
 597             xj=c(1,nres+j)-xi
 598             yj=c(2,nres+j)-yi
 599             zj=c(3,nres+j)-zi
 600 C Change 12/1/95 to calculate four-body interactions
 601             rij=xj*xj+yj*yj+zj*zj
 602             rrij=1.0D0/rij
 603 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 604             eps0ij=eps(itypi,itypj)
 605             fac=rrij**expon2
 606             e1=fac*fac*aa
 607             e2=fac*bb
 608             evdwij=e1+e2
 609             ij=icant(itypi,itypj)
 610 c ROZNICA z cluster
 611             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 612             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 613 c
 614
 615 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 616 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 617 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 618 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 619 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 620 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 621             if (bb.gt.0.0d0) then
 622               evdw=evdw+evdwij
 623             else
 624               evdw_t=evdw_t+evdwij
 625             endif
 626             if (calc_grad) then
 627 C
 628 C Calculate the components of the gradient in DC and X
 629 C
 630             fac=-rrij*(e1+evdwij)
 631             gg(1)=xj*fac
 632             gg(2)=yj*fac
 633             gg(3)=zj*fac
 634             do k=1,3
 635               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 636               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 637             enddo
 638             do k=i,j-1
 639               do l=1,3
 640                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 641               enddo
 642             enddo
 643             endif
 644 C
 645 C 12/1/95, revised on 5/20/97
 646 C
 647 C Calculate the contact function. The ith column of the array JCONT will
 648 C contain the numbers of atoms that make contacts with the atom I (of numbers
 649 C greater than I). The arrays FACONT and GACONT will contain the values of
 650 C the contact function and its derivative.
 651 C
 652 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 653 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 654 C Uncomment next line, if the correlation interactions are contact function only
 655             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 656               rij=dsqrt(rij)
 657               sigij=sigma(itypi,itypj)
 658               r0ij=rs0(itypi,itypj)
 659 C
 660 C Check whether the SC's are not too far to make a contact.
 661 C
 662               rcut=1.5d0*r0ij
 663               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 664 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 665 C
 666               if (fcont.gt.0.0D0) then
 667 C If the SC-SC distance if close to sigma, apply spline.
 668 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 669 cAdam &             fcont1,fprimcont1)
 670 cAdam           fcont1=1.0d0-fcont1
 671 cAdam           if (fcont1.gt.0.0d0) then
 672 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 673 cAdam             fcont=fcont*fcont1
 674 cAdam           endif
 675 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 676 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 677 cga             do k=1,3
 678 cga               gg(k)=gg(k)*eps0ij
 679 cga             enddo
 680 cga             eps0ij=-evdwij*eps0ij
 681 C Uncomment for AL's type of SC correlation interactions.
 682 cadam           eps0ij=-evdwij
 683                 num_conti=num_conti+1
 684                 jcont(num_conti,i)=j
 685                 facont(num_conti,i)=fcont*eps0ij
 686                 fprimcont=eps0ij*fprimcont/rij
 687                 fcont=expon*fcont
 688 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 689 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 690 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 691 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 692                 gacont(1,num_conti,i)=-fprimcont*xj
 693                 gacont(2,num_conti,i)=-fprimcont*yj
 694                 gacont(3,num_conti,i)=-fprimcont*zj
 695 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 696 cd              write (iout,'(2i3,3f10.5)')
 697 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 698               endif
 699             endif
 700           enddo      ! j
 701         enddo        ! iint
 702 C Change 12/1/95
 703         num_cont(i)=num_conti
 704       enddo          ! i
 705       if (calc_grad) then
 706       do i=1,nct
 707         do j=1,3
 708           gvdwc(j,i)=expon*gvdwc(j,i)
 709           gvdwx(j,i)=expon*gvdwx(j,i)
 710         enddo
 711       enddo
 712       endif
 713 C******************************************************************************
 714 C
 715 C                              N O T E !!!
 716 C
 717 C To save time, the factor of EXPON has been extracted from ALL components
 718 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 719 C use!
 720 C
 721 C******************************************************************************
 722       return
 723       end
 724 C-----------------------------------------------------------------------------
 725       subroutine eljk(evdw,evdw_t)
 726 C
 727 C This subroutine calculates the interaction energy of nonbonded side chains
 728 C assuming the LJK potential of interaction.
 729 C
 730       implicit real*8 (a-h,o-z)
 731       include 'DIMENSIONS'
 732       include 'DIMENSIONS.ZSCOPT'
 733       include "DIMENSIONS.COMPAR"
 734       include 'COMMON.GEO'
 735       include 'COMMON.VAR'
 736       include 'COMMON.LOCAL'
 737       include 'COMMON.CHAIN'
 738       include 'COMMON.DERIV'
 739       include 'COMMON.INTERACT'
 740       include 'COMMON.ENEPS'
 741       include 'COMMON.IOUNITS'
 742       include 'COMMON.NAMES'
 743       dimension gg(3)
 744       logical scheck
 745       integer icant
 746       external icant
 747 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 748       do i=1,210
 749         do j=1,2
 750           eneps_temp(j,i)=0.0d0
 751         enddo
 752       enddo
 753       evdw=0.0D0
 754       evdw_t=0.0d0
 755       do i=iatsc_s,iatsc_e
 756         itypi=iabs(itype(i))
 757         if (itypi.eq.ntyp1) cycle
 758         itypi1=iabs(itype(i+1))
 759         xi=c(1,nres+i)
 760         yi=c(2,nres+i)
 761         zi=c(3,nres+i)
 762 C
 763 C Calculate SC interaction energy.
 764 C
 765         do iint=1,nint_gr(i)
 766           do j=istart(i,iint),iend(i,iint)
 767             itypj=iabs(itype(j))
 768             if (itypj.eq.ntyp1) cycle
 769             xj=c(1,nres+j)-xi
 770             yj=c(2,nres+j)-yi
 771             zj=c(3,nres+j)-zi
 772             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 773             fac_augm=rrij**expon
 774             e_augm=augm(itypi,itypj)*fac_augm
 775             r_inv_ij=dsqrt(rrij)
 776             rij=1.0D0/r_inv_ij
 777             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 778             fac=r_shift_inv**expon
 779             e1=fac*fac*aa
 780             e2=fac*bb
 781             evdwij=e_augm+e1+e2
 782             ij=icant(itypi,itypj)
 783             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 784      &        /dabs(eps(itypi,itypj))
 785             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 786 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 787 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 788 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 789 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 790 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 791 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 792 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 793             if (bb.gt.0.0d0) then
 794               evdw=evdw+evdwij
 795             else
 796               evdw_t=evdw_t+evdwij
 797             endif
 798             if (calc_grad) then
 799 C
 800 C Calculate the components of the gradient in DC and X
 801 C
 802             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 803             gg(1)=xj*fac
 804             gg(2)=yj*fac
 805             gg(3)=zj*fac
 806             do k=1,3
 807               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 808               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 809             enddo
 810             do k=i,j-1
 811               do l=1,3
 812                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 813               enddo
 814             enddo
 815             endif
 816           enddo      ! j
 817         enddo        ! iint
 818       enddo          ! i
 819       if (calc_grad) then
 820       do i=1,nct
 821         do j=1,3
 822           gvdwc(j,i)=expon*gvdwc(j,i)
 823           gvdwx(j,i)=expon*gvdwx(j,i)
 824         enddo
 825       enddo
 826       endif
 827       return
 828       end
 829 C-----------------------------------------------------------------------------
 830       subroutine ebp(evdw,evdw_t)
 831 C
 832 C This subroutine calculates the interaction energy of nonbonded side chains
 833 C assuming the Berne-Pechukas potential of interaction.
 834 C
 835       implicit real*8 (a-h,o-z)
 836       include 'DIMENSIONS'
 837       include 'DIMENSIONS.ZSCOPT'
 838       include "DIMENSIONS.COMPAR"
 839       include 'COMMON.GEO'
 840       include 'COMMON.VAR'
 841       include 'COMMON.LOCAL'
 842       include 'COMMON.CHAIN'
 843       include 'COMMON.DERIV'
 844       include 'COMMON.NAMES'
 845       include 'COMMON.INTERACT'
 846       include 'COMMON.ENEPS'
 847       include 'COMMON.IOUNITS'
 848       include 'COMMON.CALC'
 849       common /srutu/ icall
 850 c     double precision rrsave(maxdim)
 851       logical lprn
 852       integer icant
 853       external icant
 854       do i=1,210
 855         do j=1,2
 856           eneps_temp(j,i)=0.0d0
 857         enddo
 858       enddo
 859       evdw=0.0D0
 860       evdw_t=0.0d0
 861 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 862 c     if (icall.eq.0) then
 863 c       lprn=.true.
 864 c     else
 865         lprn=.false.
 866 c     endif
 867       ind=0
 868       do i=iatsc_s,iatsc_e
 869         itypi=iabs(itype(i))
 870         if (itypi.eq.ntyp1) cycle
 871         itypi1=iabs(itype(i+1))
 872         xi=c(1,nres+i)
 873         yi=c(2,nres+i)
 874         zi=c(3,nres+i)
 875         dxi=dc_norm(1,nres+i)
 876         dyi=dc_norm(2,nres+i)
 877         dzi=dc_norm(3,nres+i)
 878         dsci_inv=vbld_inv(i+nres)
 879 C
 880 C Calculate SC interaction energy.
 881 C
 882         do iint=1,nint_gr(i)
 883           do j=istart(i,iint),iend(i,iint)
 884             ind=ind+1
 885             itypj=iabs(itype(j))
 886             if (itypj.eq.ntyp1) cycle
 887             dscj_inv=vbld_inv(j+nres)
 888             chi1=chi(itypi,itypj)
 889             chi2=chi(itypj,itypi)
 890             chi12=chi1*chi2
 891             chip1=chip(itypi)
 892             chip2=chip(itypj)
 893             chip12=chip1*chip2
 894             alf1=alp(itypi)
 895             alf2=alp(itypj)
 896             alf12=0.5D0*(alf1+alf2)
 897 C For diagnostics only!!!
 898 c           chi1=0.0D0
 899 c           chi2=0.0D0
 900 c           chi12=0.0D0
 901 c           chip1=0.0D0
 902 c           chip2=0.0D0
 903 c           chip12=0.0D0
 904 c           alf1=0.0D0
 905 c           alf2=0.0D0
 906 c           alf12=0.0D0
 907             xj=c(1,nres+j)-xi
 908             yj=c(2,nres+j)-yi
 909             zj=c(3,nres+j)-zi
 910             dxj=dc_norm(1,nres+j)
 911             dyj=dc_norm(2,nres+j)
 912             dzj=dc_norm(3,nres+j)
 913             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 914 cd          if (icall.eq.0) then
 915 cd            rrsave(ind)=rrij
 916 cd          else
 917 cd            rrij=rrsave(ind)
 918 cd          endif
 919             rij=dsqrt(rrij)
 920 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 921             call sc_angular
 922 C Calculate whole angle-dependent part of epsilon and contributions
 923 C to its derivatives
 924             fac=(rrij*sigsq)**expon2
 925             e1=fac*fac*aa
 926             e2=fac*bb
 927             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 928             eps2der=evdwij*eps3rt
 929             eps3der=evdwij*eps2rt
 930             evdwij=evdwij*eps2rt*eps3rt
 931             ij=icant(itypi,itypj)
 932             aux=eps1*eps2rt**2*eps3rt**2
 933             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 934      &        /dabs(eps(itypi,itypj))
 935             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 936             if (bb.gt.0.0d0) then
 937               evdw=evdw+evdwij
 938             else
 939               evdw_t=evdw_t+evdwij
 940             endif
 941             if (calc_grad) then
 942             if (lprn) then
 943             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 944             epsi=bb**2/aa
 945             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 946      &        restyp(itypi),i,restyp(itypj),j,
 947      &        epsi,sigm,chi1,chi2,chip1,chip2,
 948      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 949      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 950      &        evdwij
 951             endif
 952 C Calculate gradient components.
 953             e1=e1*eps1*eps2rt**2*eps3rt**2
 954             fac=-expon*(e1+evdwij)
 955             sigder=fac/sigsq
 956             fac=rrij*fac
 957 C Calculate radial part of the gradient
 958             gg(1)=xj*fac
 959             gg(2)=yj*fac
 960             gg(3)=zj*fac
 961 C Calculate the angular part of the gradient and sum add the contributions
 962 C to the appropriate components of the Cartesian gradient.
 963             call sc_grad
 964             endif
 965           enddo      ! j
 966         enddo        ! iint
 967       enddo          ! i
 968 c     stop
 969       return
 970       end
 971 C-----------------------------------------------------------------------------
 972       subroutine egb(evdw,evdw_t)
 973 C
 974 C This subroutine calculates the interaction energy of nonbonded side chains
 975 C assuming the Gay-Berne potential of interaction.
 976 C
 977       implicit real*8 (a-h,o-z)
 978       include 'DIMENSIONS'
 979       include 'DIMENSIONS.ZSCOPT'
 980       include "DIMENSIONS.COMPAR"
 981       include 'COMMON.GEO'
 982       include 'COMMON.VAR'
 983       include 'COMMON.LOCAL'
 984       include 'COMMON.CHAIN'
 985       include 'COMMON.DERIV'
 986       include 'COMMON.NAMES'
 987       include 'COMMON.INTERACT'
 988       include 'COMMON.ENEPS'
 989       include 'COMMON.IOUNITS'
 990       include 'COMMON.CALC'
 991       include 'COMMON.SBRIDGE'
 992       logical lprn
 993       common /srutu/icall
 994       integer icant,xshift,yshift,zshift
 995       external icant
 996       do i=1,210
 997         do j=1,2
 998           eneps_temp(j,i)=0.0d0
 999         enddo
1000       enddo
1001 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1002       evdw=0.0D0
1003       evdw_t=0.0d0
1004       lprn=.false.
1005 c      if (icall.gt.0) lprn=.true.
1006       ind=0
1007       do i=iatsc_s,iatsc_e
1008         itypi=iabs(itype(i))
1009         if (itypi.eq.ntyp1) cycle
1010         itypi1=iabs(itype(i+1))
1011         xi=c(1,nres+i)
1012         yi=c(2,nres+i)
1013         zi=c(3,nres+i)
1014 C returning the ith atom to box
1015           xi=mod(xi,boxxsize)
1016           if (xi.lt.0) xi=xi+boxxsize
1017           yi=mod(yi,boxysize)
1018           if (yi.lt.0) yi=yi+boxysize
1019           zi=mod(zi,boxzsize)
1020           if (zi.lt.0) zi=zi+boxzsize
1021        if ((zi.gt.bordlipbot)
1022      &.and.(zi.lt.bordliptop)) then
1023 C the energy transfer exist
1024         if (zi.lt.buflipbot) then
1025 C what fraction I am in
1026          fracinbuf=1.0d0-
1027      &        ((zi-bordlipbot)/lipbufthick)
1028 C lipbufthick is thickenes of lipid buffore
1029          sslipi=sscalelip(fracinbuf)
1030          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1031         elseif (zi.gt.bufliptop) then
1032          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1033          sslipi=sscalelip(fracinbuf)
1034          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1035         else
1036          sslipi=1.0d0
1037          ssgradlipi=0.0
1038         endif
1039        else
1040          sslipi=0.0d0
1041          ssgradlipi=0.0
1042        endif
1043
1044         dxi=dc_norm(1,nres+i)
1045         dyi=dc_norm(2,nres+i)
1046         dzi=dc_norm(3,nres+i)
1047         dsci_inv=vbld_inv(i+nres)
1048 C
1049 C Calculate SC interaction energy.
1050 C
1051         do iint=1,nint_gr(i)
1052           do j=istart(i,iint),iend(i,iint)
1053             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1054               call dyn_ssbond_ene(i,j,evdwij)
1055               evdw=evdw+evdwij
1056 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1057 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1058 C triple bond artifac removal
1059              do k=j+1,iend(i,iint)
1060 C search over all next residues
1061               if (dyn_ss_mask(k)) then
1062 C check if they are cysteins
1063 C              write(iout,*) 'k=',k
1064               call triple_ssbond_ene(i,j,k,evdwij)
1065 C call the energy function that removes the artifical triple disulfide
1066 C bond the soubroutine is located in ssMD.F
1067               evdw=evdw+evdwij
1068 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1069 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1070               endif!dyn_ss_mask(k)
1071              enddo! k
1072             ELSE
1073             ind=ind+1
1074             itypj=iabs(itype(j))
1075             if (itypj.eq.ntyp1) cycle
1076             dscj_inv=vbld_inv(j+nres)
1077             sig0ij=sigma(itypi,itypj)
1078             chi1=chi(itypi,itypj)
1079             chi2=chi(itypj,itypi)
1080             chi12=chi1*chi2
1081             chip1=chip(itypi)
1082             chip2=chip(itypj)
1083             chip12=chip1*chip2
1084             alf1=alp(itypi)
1085             alf2=alp(itypj)
1086             alf12=0.5D0*(alf1+alf2)
1087 C For diagnostics only!!!
1088 c           chi1=0.0D0
1089 c           chi2=0.0D0
1090 c           chi12=0.0D0
1091 c           chip1=0.0D0
1092 c           chip2=0.0D0
1093 c           chip12=0.0D0
1094 c           alf1=0.0D0
1095 c           alf2=0.0D0
1096 c           alf12=0.0D0
1097             xj=c(1,nres+j)
1098             yj=c(2,nres+j)
1099             zj=c(3,nres+j)
1100 C returning jth atom to box
1101           xj=mod(xj,boxxsize)
1102           if (xj.lt.0) xj=xj+boxxsize
1103           yj=mod(yj,boxysize)
1104           if (yj.lt.0) yj=yj+boxysize
1105           zj=mod(zj,boxzsize)
1106           if (zj.lt.0) zj=zj+boxzsize
1107        if ((zj.gt.bordlipbot)
1108      &.and.(zj.lt.bordliptop)) then
1109 C the energy transfer exist
1110         if (zj.lt.buflipbot) then
1111 C what fraction I am in
1112          fracinbuf=1.0d0-
1113      &        ((zj-bordlipbot)/lipbufthick)
1114 C lipbufthick is thickenes of lipid buffore
1115          sslipj=sscalelip(fracinbuf)
1116          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1117         elseif (zj.gt.bufliptop) then
1118          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1119          sslipj=sscalelip(fracinbuf)
1120          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1121         else
1122          sslipj=1.0d0
1123          ssgradlipj=0.0
1124         endif
1125        else
1126          sslipj=0.0d0
1127          ssgradlipj=0.0
1128        endif
1129       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1130      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1131       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1132      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1133 C       if (aa.ne.aa_aq(itypi,itypj)) then
1134
1135 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1136 C     & bb_aq(itypi,itypj)-bb,
1137 C     & sslipi,sslipj
1138 C         endif
1139
1140 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1141 C checking the distance
1142       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1143       xj_safe=xj
1144       yj_safe=yj
1145       zj_safe=zj
1146       subchap=0
1147 C finding the closest
1148       do xshift=-1,1
1149       do yshift=-1,1
1150       do zshift=-1,1
1151           xj=xj_safe+xshift*boxxsize
1152           yj=yj_safe+yshift*boxysize
1153           zj=zj_safe+zshift*boxzsize
1154           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1155           if(dist_temp.lt.dist_init) then
1156             dist_init=dist_temp
1157             xj_temp=xj
1158             yj_temp=yj
1159             zj_temp=zj
1160             subchap=1
1161           endif
1162        enddo
1163        enddo
1164        enddo
1165        if (subchap.eq.1) then
1166           xj=xj_temp-xi
1167           yj=yj_temp-yi
1168           zj=zj_temp-zi
1169        else
1170           xj=xj_safe-xi
1171           yj=yj_safe-yi
1172           zj=zj_safe-zi
1173        endif
1174
1175             dxj=dc_norm(1,nres+j)
1176             dyj=dc_norm(2,nres+j)
1177             dzj=dc_norm(3,nres+j)
1178 c            write (iout,*) i,j,xj,yj,zj
1179             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1180             rij=dsqrt(rrij)
1181             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1182             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1183             if (sss.le.0.0) cycle
1184 C Calculate angle-dependent terms of energy and contributions to their
1185 C derivatives.
1186
1187             call sc_angular
1188             sigsq=1.0D0/sigsq
1189             sig=sig0ij*dsqrt(sigsq)
1190             rij_shift=1.0D0/rij-sig+sig0ij
1191 C I hate to put IF's in the loops, but here don't have another choice!!!!
1192             if (rij_shift.le.0.0D0) then
1193               evdw=1.0D20
1194               return
1195             endif
1196             sigder=-sig*sigsq
1197 c---------------------------------------------------------------
1198             rij_shift=1.0D0/rij_shift
1199             fac=rij_shift**expon
1200             e1=fac*fac*aa
1201             e2=fac*bb
1202             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1203             eps2der=evdwij*eps3rt
1204             eps3der=evdwij*eps2rt
1205             evdwij=evdwij*eps2rt*eps3rt
1206             if (bb.gt.0) then
1207               evdw=evdw+evdwij*sss
1208             else
1209               evdw_t=evdw_t+evdwij*sss
1210             endif
1211             ij=icant(itypi,itypj)
1212             aux=eps1*eps2rt**2*eps3rt**2
1213             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1214      &        /dabs(eps(itypi,itypj))
1215             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1216 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1217 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1218 c     &         aux*e2/eps(itypi,itypj)
1219 c            if (lprn) then
1220             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1221             epsi=bb**2/aa
1222 C#define DEBUG
1223 #ifdef DEBUG
1224             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1225      &        restyp(itypi),i,restyp(itypj),j,
1226      &        epsi,sigm,chi1,chi2,chip1,chip2,
1227      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1228      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1229      &        evdwij
1230              write (iout,*) "partial sum", evdw, evdw_t
1231 #endif
1232 C#undef DEBUG
1233 c            endif
1234             if (calc_grad) then
1235 C Calculate gradient components.
1236             e1=e1*eps1*eps2rt**2*eps3rt**2
1237             fac=-expon*(e1+evdwij)*rij_shift
1238             sigder=fac*sigder
1239             fac=rij*fac
1240             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1241 C Calculate the radial part of the gradient
1242             gg(1)=xj*fac
1243             gg(2)=yj*fac
1244             gg(3)=zj*fac
1245 C Calculate angular part of the gradient.
1246             call sc_grad
1247             endif
1248 C            write(iout,*)  "partial sum", evdw, evdw_t
1249             ENDIF    ! dyn_ss
1250           enddo      ! j
1251         enddo        ! iint
1252       enddo          ! i
1253       return
1254       end
1255 C-----------------------------------------------------------------------------
1256       subroutine egbv(evdw,evdw_t)
1257 C
1258 C This subroutine calculates the interaction energy of nonbonded side chains
1259 C assuming the Gay-Berne-Vorobjev potential of interaction.
1260 C
1261       implicit real*8 (a-h,o-z)
1262       include 'DIMENSIONS'
1263       include 'DIMENSIONS.ZSCOPT'
1264       include "DIMENSIONS.COMPAR"
1265       include 'COMMON.GEO'
1266       include 'COMMON.VAR'
1267       include 'COMMON.LOCAL'
1268       include 'COMMON.CHAIN'
1269       include 'COMMON.DERIV'
1270       include 'COMMON.NAMES'
1271       include 'COMMON.INTERACT'
1272       include 'COMMON.ENEPS'
1273       include 'COMMON.IOUNITS'
1274       include 'COMMON.CALC'
1275       common /srutu/ icall
1276       logical lprn
1277       integer icant
1278       external icant
1279       do i=1,210
1280         do j=1,2
1281           eneps_temp(j,i)=0.0d0
1282         enddo
1283       enddo
1284       evdw=0.0D0
1285       evdw_t=0.0d0
1286 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1287       evdw=0.0D0
1288       lprn=.false.
1289 c      if (icall.gt.0) lprn=.true.
1290       ind=0
1291       do i=iatsc_s,iatsc_e
1292         itypi=iabs(itype(i))
1293         if (itypi.eq.ntyp1) cycle
1294         itypi1=iabs(itype(i+1))
1295         xi=c(1,nres+i)
1296         yi=c(2,nres+i)
1297         zi=c(3,nres+i)
1298         dxi=dc_norm(1,nres+i)
1299         dyi=dc_norm(2,nres+i)
1300         dzi=dc_norm(3,nres+i)
1301         dsci_inv=vbld_inv(i+nres)
1302 C
1303 C Calculate SC interaction energy.
1304 C
1305         do iint=1,nint_gr(i)
1306           do j=istart(i,iint),iend(i,iint)
1307             ind=ind+1
1308             itypj=iabs(itype(j))
1309             if (itypj.eq.ntyp1) cycle
1310             dscj_inv=vbld_inv(j+nres)
1311             sig0ij=sigma(itypi,itypj)
1312             r0ij=r0(itypi,itypj)
1313             chi1=chi(itypi,itypj)
1314             chi2=chi(itypj,itypi)
1315             chi12=chi1*chi2
1316             chip1=chip(itypi)
1317             chip2=chip(itypj)
1318             chip12=chip1*chip2
1319             alf1=alp(itypi)
1320             alf2=alp(itypj)
1321             alf12=0.5D0*(alf1+alf2)
1322 C For diagnostics only!!!
1323 c           chi1=0.0D0
1324 c           chi2=0.0D0
1325 c           chi12=0.0D0
1326 c           chip1=0.0D0
1327 c           chip2=0.0D0
1328 c           chip12=0.0D0
1329 c           alf1=0.0D0
1330 c           alf2=0.0D0
1331 c           alf12=0.0D0
1332             xj=c(1,nres+j)-xi
1333             yj=c(2,nres+j)-yi
1334             zj=c(3,nres+j)-zi
1335             dxj=dc_norm(1,nres+j)
1336             dyj=dc_norm(2,nres+j)
1337             dzj=dc_norm(3,nres+j)
1338             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1339             rij=dsqrt(rrij)
1340 C Calculate angle-dependent terms of energy and contributions to their
1341 C derivatives.
1342             call sc_angular
1343             sigsq=1.0D0/sigsq
1344             sig=sig0ij*dsqrt(sigsq)
1345             rij_shift=1.0D0/rij-sig+r0ij
1346 C I hate to put IF's in the loops, but here don't have another choice!!!!
1347             if (rij_shift.le.0.0D0) then
1348               evdw=1.0D20
1349               return
1350             endif
1351             sigder=-sig*sigsq
1352 c---------------------------------------------------------------
1353             rij_shift=1.0D0/rij_shift
1354             fac=rij_shift**expon
1355             e1=fac*fac*aa
1356             e2=fac*bb
1357             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1358             eps2der=evdwij*eps3rt
1359             eps3der=evdwij*eps2rt
1360             fac_augm=rrij**expon
1361             e_augm=augm(itypi,itypj)*fac_augm
1362             evdwij=evdwij*eps2rt*eps3rt
1363             if (bb.gt.0.0d0) then
1364               evdw=evdw+evdwij+e_augm
1365             else
1366               evdw_t=evdw_t+evdwij+e_augm
1367             endif
1368             ij=icant(itypi,itypj)
1369             aux=eps1*eps2rt**2*eps3rt**2
1370             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1371      &        /dabs(eps(itypi,itypj))
1372             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1373 c            eneps_temp(ij)=eneps_temp(ij)
1374 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1375 c            if (lprn) then
1376 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1377 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1378 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1379 c     &        restyp(itypi),i,restyp(itypj),j,
1380 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1381 c     &        chi1,chi2,chip1,chip2,
1382 c     &        eps1,eps2rt**2,eps3rt**2,
1383 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1384 c     &        evdwij+e_augm
1385 c            endif
1386             if (calc_grad) then
1387 C Calculate gradient components.
1388             e1=e1*eps1*eps2rt**2*eps3rt**2
1389             fac=-expon*(e1+evdwij)*rij_shift
1390             sigder=fac*sigder
1391             fac=rij*fac-2*expon*rrij*e_augm
1392 C Calculate the radial part of the gradient
1393             gg(1)=xj*fac
1394             gg(2)=yj*fac
1395             gg(3)=zj*fac
1396 C Calculate angular part of the gradient.
1397             call sc_grad
1398             endif
1399           enddo      ! j
1400         enddo        ! iint
1401       enddo          ! i
1402       return
1403       end
1404 C-----------------------------------------------------------------------------
1405       subroutine sc_angular
1406 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1407 C om12. Called by ebp, egb, and egbv.
1408       implicit none
1409       include 'COMMON.CALC'
1410       erij(1)=xj*rij
1411       erij(2)=yj*rij
1412       erij(3)=zj*rij
1413       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1414       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1415       om12=dxi*dxj+dyi*dyj+dzi*dzj
1416       chiom12=chi12*om12
1417 C Calculate eps1(om12) and its derivative in om12
1418       faceps1=1.0D0-om12*chiom12
1419       faceps1_inv=1.0D0/faceps1
1420       eps1=dsqrt(faceps1_inv)
1421 C Following variable is eps1*deps1/dom12
1422       eps1_om12=faceps1_inv*chiom12
1423 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1424 C and om12.
1425       om1om2=om1*om2
1426       chiom1=chi1*om1
1427       chiom2=chi2*om2
1428       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1429       sigsq=1.0D0-facsig*faceps1_inv
1430       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1431       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1432       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1433 C Calculate eps2 and its derivatives in om1, om2, and om12.
1434       chipom1=chip1*om1
1435       chipom2=chip2*om2
1436       chipom12=chip12*om12
1437       facp=1.0D0-om12*chipom12
1438       facp_inv=1.0D0/facp
1439       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1440 C Following variable is the square root of eps2
1441       eps2rt=1.0D0-facp1*facp_inv
1442 C Following three variables are the derivatives of the square root of eps
1443 C in om1, om2, and om12.
1444       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1445       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1446       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1447 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1448       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1449 C Calculate whole angle-dependent part of epsilon and contributions
1450 C to its derivatives
1451       return
1452       end
1453 C----------------------------------------------------------------------------
1454       subroutine sc_grad
1455       implicit real*8 (a-h,o-z)
1456       include 'DIMENSIONS'
1457       include 'DIMENSIONS.ZSCOPT'
1458       include 'COMMON.CHAIN'
1459       include 'COMMON.DERIV'
1460       include 'COMMON.CALC'
1461       double precision dcosom1(3),dcosom2(3)
1462       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1463       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1464       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1465      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1466       do k=1,3
1467         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1468         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1469       enddo
1470       do k=1,3
1471         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1472       enddo
1473       do k=1,3
1474         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1475      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1476      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1477         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1478      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1479      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1480       enddo
1481 C
1482 C Calculate the components of the gradient in DC and X
1483 C
1484       do k=i,j-1
1485         do l=1,3
1486           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1487         enddo
1488       enddo
1489       return
1490       end
1491 c------------------------------------------------------------------------------
1492       subroutine vec_and_deriv
1493       implicit real*8 (a-h,o-z)
1494       include 'DIMENSIONS'
1495       include 'DIMENSIONS.ZSCOPT'
1496       include 'COMMON.IOUNITS'
1497       include 'COMMON.GEO'
1498       include 'COMMON.VAR'
1499       include 'COMMON.LOCAL'
1500       include 'COMMON.CHAIN'
1501       include 'COMMON.VECTORS'
1502       include 'COMMON.DERIV'
1503       include 'COMMON.INTERACT'
1504       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1505 C Compute the local reference systems. For reference system (i), the
1506 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1507 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1508       do i=1,nres-1
1509 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1510           if (i.eq.nres-1) then
1511 C Case of the last full residue
1512 C Compute the Z-axis
1513             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1514             costh=dcos(pi-theta(nres))
1515             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1516             do k=1,3
1517               uz(k,i)=fac*uz(k,i)
1518             enddo
1519             if (calc_grad) then
1520 C Compute the derivatives of uz
1521             uzder(1,1,1)= 0.0d0
1522             uzder(2,1,1)=-dc_norm(3,i-1)
1523             uzder(3,1,1)= dc_norm(2,i-1)
1524             uzder(1,2,1)= dc_norm(3,i-1)
1525             uzder(2,2,1)= 0.0d0
1526             uzder(3,2,1)=-dc_norm(1,i-1)
1527             uzder(1,3,1)=-dc_norm(2,i-1)
1528             uzder(2,3,1)= dc_norm(1,i-1)
1529             uzder(3,3,1)= 0.0d0
1530             uzder(1,1,2)= 0.0d0
1531             uzder(2,1,2)= dc_norm(3,i)
1532             uzder(3,1,2)=-dc_norm(2,i)
1533             uzder(1,2,2)=-dc_norm(3,i)
1534             uzder(2,2,2)= 0.0d0
1535             uzder(3,2,2)= dc_norm(1,i)
1536             uzder(1,3,2)= dc_norm(2,i)
1537             uzder(2,3,2)=-dc_norm(1,i)
1538             uzder(3,3,2)= 0.0d0
1539             endif
1540 C Compute the Y-axis
1541             facy=fac
1542             do k=1,3
1543               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1544             enddo
1545             if (calc_grad) then
1546 C Compute the derivatives of uy
1547             do j=1,3
1548               do k=1,3
1549                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1550      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1551                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1552               enddo
1553               uyder(j,j,1)=uyder(j,j,1)-costh
1554               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1555             enddo
1556             do j=1,2
1557               do k=1,3
1558                 do l=1,3
1559                   uygrad(l,k,j,i)=uyder(l,k,j)
1560                   uzgrad(l,k,j,i)=uzder(l,k,j)
1561                 enddo
1562               enddo
1563             enddo
1564             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1565             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1566             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1567             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1568             endif
1569           else
1570 C Other residues
1571 C Compute the Z-axis
1572             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1573             costh=dcos(pi-theta(i+2))
1574             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1575             do k=1,3
1576               uz(k,i)=fac*uz(k,i)
1577             enddo
1578             if (calc_grad) then
1579 C Compute the derivatives of uz
1580             uzder(1,1,1)= 0.0d0
1581             uzder(2,1,1)=-dc_norm(3,i+1)
1582             uzder(3,1,1)= dc_norm(2,i+1)
1583             uzder(1,2,1)= dc_norm(3,i+1)
1584             uzder(2,2,1)= 0.0d0
1585             uzder(3,2,1)=-dc_norm(1,i+1)
1586             uzder(1,3,1)=-dc_norm(2,i+1)
1587             uzder(2,3,1)= dc_norm(1,i+1)
1588             uzder(3,3,1)= 0.0d0
1589             uzder(1,1,2)= 0.0d0
1590             uzder(2,1,2)= dc_norm(3,i)
1591             uzder(3,1,2)=-dc_norm(2,i)
1592             uzder(1,2,2)=-dc_norm(3,i)
1593             uzder(2,2,2)= 0.0d0
1594             uzder(3,2,2)= dc_norm(1,i)
1595             uzder(1,3,2)= dc_norm(2,i)
1596             uzder(2,3,2)=-dc_norm(1,i)
1597             uzder(3,3,2)= 0.0d0
1598             endif
1599 C Compute the Y-axis
1600             facy=fac
1601             do k=1,3
1602               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1603             enddo
1604             if (calc_grad) then
1605 C Compute the derivatives of uy
1606             do j=1,3
1607               do k=1,3
1608                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1609      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1610                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1611               enddo
1612               uyder(j,j,1)=uyder(j,j,1)-costh
1613               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1614             enddo
1615             do j=1,2
1616               do k=1,3
1617                 do l=1,3
1618                   uygrad(l,k,j,i)=uyder(l,k,j)
1619                   uzgrad(l,k,j,i)=uzder(l,k,j)
1620                 enddo
1621               enddo
1622             enddo
1623             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1624             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1625             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1626             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1627           endif
1628           endif
1629       enddo
1630       if (calc_grad) then
1631       do i=1,nres-1
1632         vbld_inv_temp(1)=vbld_inv(i+1)
1633         if (i.lt.nres-1) then
1634           vbld_inv_temp(2)=vbld_inv(i+2)
1635         else
1636           vbld_inv_temp(2)=vbld_inv(i)
1637         endif
1638         do j=1,2
1639           do k=1,3
1640             do l=1,3
1641               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1642               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1643             enddo
1644           enddo
1645         enddo
1646       enddo
1647       endif
1648       return
1649       end
1650 C-----------------------------------------------------------------------------
1651       subroutine vec_and_deriv_test
1652       implicit real*8 (a-h,o-z)
1653       include 'DIMENSIONS'
1654       include 'DIMENSIONS.ZSCOPT'
1655       include 'COMMON.IOUNITS'
1656       include 'COMMON.GEO'
1657       include 'COMMON.VAR'
1658       include 'COMMON.LOCAL'
1659       include 'COMMON.CHAIN'
1660       include 'COMMON.VECTORS'
1661       dimension uyder(3,3,2),uzder(3,3,2)
1662 C Compute the local reference systems. For reference system (i), the
1663 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1664 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1665       do i=1,nres-1
1666           if (i.eq.nres-1) then
1667 C Case of the last full residue
1668 C Compute the Z-axis
1669             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1670             costh=dcos(pi-theta(nres))
1671             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1672 c            write (iout,*) 'fac',fac,
1673 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1674             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1675             do k=1,3
1676               uz(k,i)=fac*uz(k,i)
1677             enddo
1678 C Compute the derivatives of uz
1679             uzder(1,1,1)= 0.0d0
1680             uzder(2,1,1)=-dc_norm(3,i-1)
1681             uzder(3,1,1)= dc_norm(2,i-1)
1682             uzder(1,2,1)= dc_norm(3,i-1)
1683             uzder(2,2,1)= 0.0d0
1684             uzder(3,2,1)=-dc_norm(1,i-1)
1685             uzder(1,3,1)=-dc_norm(2,i-1)
1686             uzder(2,3,1)= dc_norm(1,i-1)
1687             uzder(3,3,1)= 0.0d0
1688             uzder(1,1,2)= 0.0d0
1689             uzder(2,1,2)= dc_norm(3,i)
1690             uzder(3,1,2)=-dc_norm(2,i)
1691             uzder(1,2,2)=-dc_norm(3,i)
1692             uzder(2,2,2)= 0.0d0
1693             uzder(3,2,2)= dc_norm(1,i)
1694             uzder(1,3,2)= dc_norm(2,i)
1695             uzder(2,3,2)=-dc_norm(1,i)
1696             uzder(3,3,2)= 0.0d0
1697 C Compute the Y-axis
1698             do k=1,3
1699               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1700             enddo
1701             facy=fac
1702             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1703      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1704      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1705             do k=1,3
1706 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1707               uy(k,i)=
1708 c     &        facy*(
1709      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1710      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1711 c     &        )
1712             enddo
1713 c            write (iout,*) 'facy',facy,
1714 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1715             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1716             do k=1,3
1717               uy(k,i)=facy*uy(k,i)
1718             enddo
1719 C Compute the derivatives of uy
1720             do j=1,3
1721               do k=1,3
1722                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1723      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1724                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1725               enddo
1726 c              uyder(j,j,1)=uyder(j,j,1)-costh
1727 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1728               uyder(j,j,1)=uyder(j,j,1)
1729      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1730               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1731      &          +uyder(j,j,2)
1732             enddo
1733             do j=1,2
1734               do k=1,3
1735                 do l=1,3
1736                   uygrad(l,k,j,i)=uyder(l,k,j)
1737                   uzgrad(l,k,j,i)=uzder(l,k,j)
1738                 enddo
1739               enddo
1740             enddo
1741             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1742             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1743             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1744             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1745           else
1746 C Other residues
1747 C Compute the Z-axis
1748             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1749             costh=dcos(pi-theta(i+2))
1750             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1751             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1752             do k=1,3
1753               uz(k,i)=fac*uz(k,i)
1754             enddo
1755 C Compute the derivatives of uz
1756             uzder(1,1,1)= 0.0d0
1757             uzder(2,1,1)=-dc_norm(3,i+1)
1758             uzder(3,1,1)= dc_norm(2,i+1)
1759             uzder(1,2,1)= dc_norm(3,i+1)
1760             uzder(2,2,1)= 0.0d0
1761             uzder(3,2,1)=-dc_norm(1,i+1)
1762             uzder(1,3,1)=-dc_norm(2,i+1)
1763             uzder(2,3,1)= dc_norm(1,i+1)
1764             uzder(3,3,1)= 0.0d0
1765             uzder(1,1,2)= 0.0d0
1766             uzder(2,1,2)= dc_norm(3,i)
1767             uzder(3,1,2)=-dc_norm(2,i)
1768             uzder(1,2,2)=-dc_norm(3,i)
1769             uzder(2,2,2)= 0.0d0
1770             uzder(3,2,2)= dc_norm(1,i)
1771             uzder(1,3,2)= dc_norm(2,i)
1772             uzder(2,3,2)=-dc_norm(1,i)
1773             uzder(3,3,2)= 0.0d0
1774 C Compute the Y-axis
1775             facy=fac
1776             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1777      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1778      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1779             do k=1,3
1780 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1781               uy(k,i)=
1782 c     &        facy*(
1783      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1784      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1785 c     &        )
1786             enddo
1787 c            write (iout,*) 'facy',facy,
1788 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1789             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1790             do k=1,3
1791               uy(k,i)=facy*uy(k,i)
1792             enddo
1793 C Compute the derivatives of uy
1794             do j=1,3
1795               do k=1,3
1796                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1797      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1798                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1799               enddo
1800 c              uyder(j,j,1)=uyder(j,j,1)-costh
1801 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1802               uyder(j,j,1)=uyder(j,j,1)
1803      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1804               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1805      &          +uyder(j,j,2)
1806             enddo
1807             do j=1,2
1808               do k=1,3
1809                 do l=1,3
1810                   uygrad(l,k,j,i)=uyder(l,k,j)
1811                   uzgrad(l,k,j,i)=uzder(l,k,j)
1812                 enddo
1813               enddo
1814             enddo
1815             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1816             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1817             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1818             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1819           endif
1820       enddo
1821       do i=1,nres-1
1822         do j=1,2
1823           do k=1,3
1824             do l=1,3
1825               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1826               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1827             enddo
1828           enddo
1829         enddo
1830       enddo
1831       return
1832       end
1833 C-----------------------------------------------------------------------------
1834       subroutine check_vecgrad
1835       implicit real*8 (a-h,o-z)
1836       include 'DIMENSIONS'
1837       include 'DIMENSIONS.ZSCOPT'
1838       include 'COMMON.IOUNITS'
1839       include 'COMMON.GEO'
1840       include 'COMMON.VAR'
1841       include 'COMMON.LOCAL'
1842       include 'COMMON.CHAIN'
1843       include 'COMMON.VECTORS'
1844       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1845       dimension uyt(3,maxres),uzt(3,maxres)
1846       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1847       double precision delta /1.0d-7/
1848       call vec_and_deriv
1849 cd      do i=1,nres
1850 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1851 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1852 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1853 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1854 cd     &     (dc_norm(if90,i),if90=1,3)
1855 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1856 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1857 cd          write(iout,'(a)')
1858 cd      enddo
1859       do i=1,nres
1860         do j=1,2
1861           do k=1,3
1862             do l=1,3
1863               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1864               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1865             enddo
1866           enddo
1867         enddo
1868       enddo
1869       call vec_and_deriv
1870       do i=1,nres
1871         do j=1,3
1872           uyt(j,i)=uy(j,i)
1873           uzt(j,i)=uz(j,i)
1874         enddo
1875       enddo
1876       do i=1,nres
1877 cd        write (iout,*) 'i=',i
1878         do k=1,3
1879           erij(k)=dc_norm(k,i)
1880         enddo
1881         do j=1,3
1882           do k=1,3
1883             dc_norm(k,i)=erij(k)
1884           enddo
1885           dc_norm(j,i)=dc_norm(j,i)+delta
1886 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1887 c          do k=1,3
1888 c            dc_norm(k,i)=dc_norm(k,i)/fac
1889 c          enddo
1890 c          write (iout,*) (dc_norm(k,i),k=1,3)
1891 c          write (iout,*) (erij(k),k=1,3)
1892           call vec_and_deriv
1893           do k=1,3
1894             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1895             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1896             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1897             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1898           enddo
1899 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1900 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1901 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1902         enddo
1903         do k=1,3
1904           dc_norm(k,i)=erij(k)
1905         enddo
1906 cd        do k=1,3
1907 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1908 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1909 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1910 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1911 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1912 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1913 cd          write (iout,'(a)')
1914 cd        enddo
1915       enddo
1916       return
1917       end
1918 C--------------------------------------------------------------------------
1919       subroutine set_matrices
1920       implicit real*8 (a-h,o-z)
1921       include 'DIMENSIONS'
1922       include 'DIMENSIONS.ZSCOPT'
1923       include 'COMMON.IOUNITS'
1924       include 'COMMON.GEO'
1925       include 'COMMON.VAR'
1926       include 'COMMON.LOCAL'
1927       include 'COMMON.CHAIN'
1928       include 'COMMON.DERIV'
1929       include 'COMMON.INTERACT'
1930       include 'COMMON.CONTACTS'
1931       include 'COMMON.TORSION'
1932       include 'COMMON.VECTORS'
1933       include 'COMMON.FFIELD'
1934       double precision auxvec(2),auxmat(2,2)
1935 C
1936 C Compute the virtual-bond-torsional-angle dependent quantities needed
1937 C to calculate the el-loc multibody terms of various order.
1938 C
1939       do i=3,nres+1
1940         if (i .lt. nres+1) then
1941           sin1=dsin(phi(i))
1942           cos1=dcos(phi(i))
1943           sintab(i-2)=sin1
1944           costab(i-2)=cos1
1945           obrot(1,i-2)=cos1
1946           obrot(2,i-2)=sin1
1947           sin2=dsin(2*phi(i))
1948           cos2=dcos(2*phi(i))
1949           sintab2(i-2)=sin2
1950           costab2(i-2)=cos2
1951           obrot2(1,i-2)=cos2
1952           obrot2(2,i-2)=sin2
1953           Ug(1,1,i-2)=-cos1
1954           Ug(1,2,i-2)=-sin1
1955           Ug(2,1,i-2)=-sin1
1956           Ug(2,2,i-2)= cos1
1957           Ug2(1,1,i-2)=-cos2
1958           Ug2(1,2,i-2)=-sin2
1959           Ug2(2,1,i-2)=-sin2
1960           Ug2(2,2,i-2)= cos2
1961         else
1962           costab(i-2)=1.0d0
1963           sintab(i-2)=0.0d0
1964           obrot(1,i-2)=1.0d0
1965           obrot(2,i-2)=0.0d0
1966           obrot2(1,i-2)=0.0d0
1967           obrot2(2,i-2)=0.0d0
1968           Ug(1,1,i-2)=1.0d0
1969           Ug(1,2,i-2)=0.0d0
1970           Ug(2,1,i-2)=0.0d0
1971           Ug(2,2,i-2)=1.0d0
1972           Ug2(1,1,i-2)=0.0d0
1973           Ug2(1,2,i-2)=0.0d0
1974           Ug2(2,1,i-2)=0.0d0
1975           Ug2(2,2,i-2)=0.0d0
1976         endif
1977         if (i .gt. 3 .and. i .lt. nres+1) then
1978           obrot_der(1,i-2)=-sin1
1979           obrot_der(2,i-2)= cos1
1980           Ugder(1,1,i-2)= sin1
1981           Ugder(1,2,i-2)=-cos1
1982           Ugder(2,1,i-2)=-cos1
1983           Ugder(2,2,i-2)=-sin1
1984           dwacos2=cos2+cos2
1985           dwasin2=sin2+sin2
1986           obrot2_der(1,i-2)=-dwasin2
1987           obrot2_der(2,i-2)= dwacos2
1988           Ug2der(1,1,i-2)= dwasin2
1989           Ug2der(1,2,i-2)=-dwacos2
1990           Ug2der(2,1,i-2)=-dwacos2
1991           Ug2der(2,2,i-2)=-dwasin2
1992         else
1993           obrot_der(1,i-2)=0.0d0
1994           obrot_der(2,i-2)=0.0d0
1995           Ugder(1,1,i-2)=0.0d0
1996           Ugder(1,2,i-2)=0.0d0
1997           Ugder(2,1,i-2)=0.0d0
1998           Ugder(2,2,i-2)=0.0d0
1999           obrot2_der(1,i-2)=0.0d0
2000           obrot2_der(2,i-2)=0.0d0
2001           Ug2der(1,1,i-2)=0.0d0
2002           Ug2der(1,2,i-2)=0.0d0
2003           Ug2der(2,1,i-2)=0.0d0
2004           Ug2der(2,2,i-2)=0.0d0
2005         endif
2006         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2007           if (itype(i-2).le.ntyp) then
2008             iti = itortyp(itype(i-2))
2009           else
2010             iti=ntortyp+1
2011           endif
2012         else
2013           iti=ntortyp+1
2014         endif
2015         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2016           if (itype(i-1).le.ntyp) then
2017             iti1 = itortyp(itype(i-1))
2018           else
2019             iti1=ntortyp+1
2020           endif
2021         else
2022           iti1=ntortyp+1
2023         endif
2024 cd        write (iout,*) '*******i',i,' iti1',iti
2025 cd        write (iout,*) 'b1',b1(:,iti)
2026 cd        write (iout,*) 'b2',b2(:,iti)
2027 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2028 c        print *,"itilde1 i iti iti1",i,iti,iti1
2029         if (i .gt. iatel_s+2) then
2030           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2031           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2032           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2033           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2034           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2035           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2036           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2037         else
2038           do k=1,2
2039             Ub2(k,i-2)=0.0d0
2040             Ctobr(k,i-2)=0.0d0
2041             Dtobr2(k,i-2)=0.0d0
2042             do l=1,2
2043               EUg(l,k,i-2)=0.0d0
2044               CUg(l,k,i-2)=0.0d0
2045               DUg(l,k,i-2)=0.0d0
2046               DtUg2(l,k,i-2)=0.0d0
2047             enddo
2048           enddo
2049         endif
2050 c        print *,"itilde2 i iti iti1",i,iti,iti1
2051         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2052         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2053         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2054         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2055         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2056         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2057         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2058 c        print *,"itilde3 i iti iti1",i,iti,iti1
2059         do k=1,2
2060           muder(k,i-2)=Ub2der(k,i-2)
2061         enddo
2062         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2063           if (itype(i-1).le.ntyp) then
2064             iti1 = itortyp(itype(i-1))
2065           else
2066             iti1=ntortyp+1
2067           endif
2068         else
2069           iti1=ntortyp+1
2070         endif
2071         do k=1,2
2072           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2073         enddo
2074 C        write (iout,*) 'mumu',i,b1(1,iti),Ub2(1,i-2)
2075
2076 C Vectors and matrices dependent on a single virtual-bond dihedral.
2077         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2078         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2079         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2080         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2081         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2082         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2083         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2084         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2085         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2086 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2087 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2088       enddo
2089 C Matrices dependent on two consecutive virtual-bond dihedrals.
2090 C The order of matrices is from left to right.
2091       do i=2,nres-1
2092         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2093         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2094         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2095         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2096         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2097         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2098         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2099         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2100       enddo
2101 cd      do i=1,nres
2102 cd        iti = itortyp(itype(i))
2103 cd        write (iout,*) i
2104 cd        do j=1,2
2105 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2106 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2107 cd        enddo
2108 cd      enddo
2109       return
2110       end
2111 C--------------------------------------------------------------------------
2112       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2113 C
2114 C This subroutine calculates the average interaction energy and its gradient
2115 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2116 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2117 C The potential depends both on the distance of peptide-group centers and on
2118 C the orientation of the CA-CA virtual bonds.
2119 C
2120       implicit real*8 (a-h,o-z)
2121       include 'DIMENSIONS'
2122       include 'DIMENSIONS.ZSCOPT'
2123       include 'COMMON.CONTROL'
2124       include 'COMMON.IOUNITS'
2125       include 'COMMON.GEO'
2126       include 'COMMON.VAR'
2127       include 'COMMON.LOCAL'
2128       include 'COMMON.CHAIN'
2129       include 'COMMON.DERIV'
2130       include 'COMMON.INTERACT'
2131       include 'COMMON.CONTACTS'
2132       include 'COMMON.TORSION'
2133       include 'COMMON.VECTORS'
2134       include 'COMMON.FFIELD'
2135       include 'COMMON.SHIELD'
2136       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2137      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2138       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2139      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2140       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2141 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2142       double precision scal_el /0.5d0/
2143 C 12/13/98
2144 C 13-go grudnia roku pamietnego...
2145       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2146      &                   0.0d0,1.0d0,0.0d0,
2147      &                   0.0d0,0.0d0,1.0d0/
2148 cd      write(iout,*) 'In EELEC'
2149 cd      do i=1,nloctyp
2150 cd        write(iout,*) 'Type',i
2151 cd        write(iout,*) 'B1',B1(:,i)
2152 cd        write(iout,*) 'B2',B2(:,i)
2153 cd        write(iout,*) 'CC',CC(:,:,i)
2154 cd        write(iout,*) 'DD',DD(:,:,i)
2155 cd        write(iout,*) 'EE',EE(:,:,i)
2156 cd      enddo
2157 cd      call check_vecgrad
2158 cd      stop
2159       if (icheckgrad.eq.1) then
2160         do i=1,nres-1
2161           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2162           do k=1,3
2163             dc_norm(k,i)=dc(k,i)*fac
2164           enddo
2165 c          write (iout,*) 'i',i,' fac',fac
2166         enddo
2167       endif
2168       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2169      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2170      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2171 cd      if (wel_loc.gt.0.0d0) then
2172         if (icheckgrad.eq.1) then
2173         call vec_and_deriv_test
2174         else
2175         call vec_and_deriv
2176         endif
2177         call set_matrices
2178       endif
2179 cd      do i=1,nres-1
2180 cd        write (iout,*) 'i=',i
2181 cd        do k=1,3
2182 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2183 cd        enddo
2184 cd        do k=1,3
2185 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2186 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2187 cd        enddo
2188 cd      enddo
2189       num_conti_hb=0
2190       ees=0.0D0
2191       evdw1=0.0D0
2192       eel_loc=0.0d0
2193       eello_turn3=0.0d0
2194       eello_turn4=0.0d0
2195       ind=0
2196       do i=1,nres
2197         num_cont_hb(i)=0
2198       enddo
2199 C      print '(a)','Enter EELEC'
2200 C      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2201       do i=1,nres
2202         gel_loc_loc(i)=0.0d0
2203         gcorr_loc(i)=0.0d0
2204       enddo
2205       do i=iatel_s,iatel_e
2206 C          if (i.eq.1) then
2207            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2208 C     &  .or. itype(i+2).eq.ntyp1) cycle
2209 C          else
2210 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2211 C     &  .or. itype(i+2).eq.ntyp1
2212 C     &  .or. itype(i-1).eq.ntyp1
2213      &) cycle
2214 C         endif
2215         if (itel(i).eq.0) goto 1215
2216         dxi=dc(1,i)
2217         dyi=dc(2,i)
2218         dzi=dc(3,i)
2219         dx_normi=dc_norm(1,i)
2220         dy_normi=dc_norm(2,i)
2221         dz_normi=dc_norm(3,i)
2222         xmedi=c(1,i)+0.5d0*dxi
2223         ymedi=c(2,i)+0.5d0*dyi
2224         zmedi=c(3,i)+0.5d0*dzi
2225           xmedi=mod(xmedi,boxxsize)
2226           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2227           ymedi=mod(ymedi,boxysize)
2228           if (ymedi.lt.0) ymedi=ymedi+boxysize
2229           zmedi=mod(zmedi,boxzsize)
2230           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2231           zmedi2=mod(zmedi,boxzsize)
2232           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
2233        if ((zmedi2.gt.bordlipbot)
2234      &.and.(zmedi2.lt.bordliptop)) then
2235 C the energy transfer exist
2236         if (zmedi2.lt.buflipbot) then
2237 C what fraction I am in
2238          fracinbuf=1.0d0-
2239      &        ((zmedi2-bordlipbot)/lipbufthick)
2240 C lipbufthick is thickenes of lipid buffore
2241          sslipi=sscalelip(fracinbuf)
2242          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2243         elseif (zmedi2.gt.bufliptop) then
2244          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
2245          sslipi=sscalelip(fracinbuf)
2246          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2247         else
2248          sslipi=1.0d0
2249          ssgradlipi=0.0d0
2250         endif
2251        else
2252          sslipi=0.0d0
2253          ssgradlipi=0.0d0
2254        endif
2255
2256         num_conti=0
2257 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2258         do j=ielstart(i),ielend(i)
2259           if (j.lt.1) cycle
2260 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2261 C     & .or.itype(j+2).eq.ntyp1
2262 C     &) cycle
2263 C          else
2264           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2265 C     & .or.itype(j+2).eq.ntyp1
2266 C     & .or.itype(j-1).eq.ntyp1
2267      &) cycle
2268 C         endif
2269 C
2270 C) cycle
2271           if (itel(j).eq.0) goto 1216
2272           ind=ind+1
2273           iteli=itel(i)
2274           itelj=itel(j)
2275           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2276           aaa=app(iteli,itelj)
2277           bbb=bpp(iteli,itelj)
2278 C Diagnostics only!!!
2279 c         aaa=0.0D0
2280 c         bbb=0.0D0
2281 c         ael6i=0.0D0
2282 c         ael3i=0.0D0
2283 C End diagnostics
2284           ael6i=ael6(iteli,itelj)
2285           ael3i=ael3(iteli,itelj)
2286           dxj=dc(1,j)
2287           dyj=dc(2,j)
2288           dzj=dc(3,j)
2289           dx_normj=dc_norm(1,j)
2290           dy_normj=dc_norm(2,j)
2291           dz_normj=dc_norm(3,j)
2292           xj=c(1,j)+0.5D0*dxj
2293           yj=c(2,j)+0.5D0*dyj
2294           zj=c(3,j)+0.5D0*dzj
2295          xj=mod(xj,boxxsize)
2296           if (xj.lt.0) xj=xj+boxxsize
2297           yj=mod(yj,boxysize)
2298           if (yj.lt.0) yj=yj+boxysize
2299           zj=mod(zj,boxzsize)
2300           if (zj.lt.0) zj=zj+boxzsize
2301        if ((zj.gt.bordlipbot)
2302      &.and.(zj.lt.bordliptop)) then
2303 C the energy transfer exist
2304         if (zj.lt.buflipbot) then
2305 C what fraction I am in
2306          fracinbuf=1.0d0-
2307      &        ((zj-bordlipbot)/lipbufthick)
2308 C lipbufthick is thickenes of lipid buffore
2309          sslipj=sscalelip(fracinbuf)
2310          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2311         elseif (zj.gt.bufliptop) then
2312          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2313          sslipj=sscalelip(fracinbuf)
2314          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2315         else
2316          sslipj=1.0d0
2317          ssgradlipj=0.0
2318         endif
2319        else
2320          sslipj=0.0d0
2321          ssgradlipj=0.0
2322        endif
2323       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2324       xj_safe=xj
2325       yj_safe=yj
2326       zj_safe=zj
2327       isubchap=0
2328       do xshift=-1,1
2329       do yshift=-1,1
2330       do zshift=-1,1
2331           xj=xj_safe+xshift*boxxsize
2332           yj=yj_safe+yshift*boxysize
2333           zj=zj_safe+zshift*boxzsize
2334           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2335           if(dist_temp.lt.dist_init) then
2336             dist_init=dist_temp
2337             xj_temp=xj
2338             yj_temp=yj
2339             zj_temp=zj
2340             isubchap=1
2341           endif
2342        enddo
2343        enddo
2344        enddo
2345        if (isubchap.eq.1) then
2346           xj=xj_temp-xmedi
2347           yj=yj_temp-ymedi
2348           zj=zj_temp-zmedi
2349        else
2350           xj=xj_safe-xmedi
2351           yj=yj_safe-ymedi
2352           zj=zj_safe-zmedi
2353        endif
2354           rij=xj*xj+yj*yj+zj*zj
2355             sss=sscale(sqrt(rij))
2356             sssgrad=sscagrad(sqrt(rij))
2357           rrmij=1.0D0/rij
2358           rij=dsqrt(rij)
2359           rmij=1.0D0/rij
2360           r3ij=rrmij*rmij
2361           r6ij=r3ij*r3ij
2362           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2363           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2364           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2365           fac=cosa-3.0D0*cosb*cosg
2366           ev1=aaa*r6ij*r6ij
2367 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2368           if (j.eq.i+2) ev1=scal_el*ev1
2369           ev2=bbb*r6ij
2370           fac3=ael6i*r6ij
2371           fac4=ael3i*r3ij
2372           evdwij=ev1+ev2
2373           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2374           el2=fac4*fac
2375           eesij=el1+el2
2376 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2377 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2378           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2379           if (shield_mode.gt.0) then
2380 C#define DEBUG
2381 #ifdef DEBUG
2382           write(iout,*) "ees_compon",i,j,el1,el2,
2383      &    fac_shield(i),fac_shield(j)
2384 #endif
2385 C#undef DEBUG
2386 C          fac_shield(i)=0.4
2387 C          fac_shield(j)=0.6
2388           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2389           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2390           eesij=(el1+el2)
2391           ees=ees+eesij
2392           else
2393           fac_shield(i)=1.0
2394           fac_shield(j)=1.0
2395           eesij=(el1+el2)
2396           ees=ees+eesij
2397           endif
2398           evdw1=evdw1+evdwij*sss
2399 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2400 c     &'evdw1',i,j,evdwij
2401 c     &,iteli,itelj,aaa,evdw1
2402
2403 C              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2404 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2405 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2406 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2407 c     &      xmedi,ymedi,zmedi,xj,yj,zj
2408 C
2409 C Calculate contributions to the Cartesian gradient.
2410 C
2411 #ifdef SPLITELE
2412           facvdw=-6*rrmij*(ev1+evdwij)*sss
2413           facel=-3*rrmij*(el1+eesij)
2414           fac1=fac
2415           erij(1)=xj*rmij
2416           erij(2)=yj*rmij
2417           erij(3)=zj*rmij
2418           if (calc_grad) then
2419 *
2420 * Radial derivatives. First process both termini of the fragment (i,j)
2421 *
2422           ggg(1)=facel*xj
2423           ggg(2)=facel*yj
2424           ggg(3)=facel*zj
2425           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2426      &  (shield_mode.gt.0)) then
2427 C          print *,i,j
2428           do ilist=1,ishield_list(i)
2429            iresshield=shield_list(ilist,i)
2430            do k=1,3
2431            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2432      &      *2.0
2433            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2434      &              rlocshield
2435      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2436             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2437 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2438 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2439 C             if (iresshield.gt.i) then
2440 C               do ishi=i+1,iresshield-1
2441 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2442 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2443 C
2444 C              enddo
2445 C             else
2446 C               do ishi=iresshield,i
2447 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2448 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2449 C
2450 C               enddo
2451 C              endif
2452            enddo
2453           enddo
2454           do ilist=1,ishield_list(j)
2455            iresshield=shield_list(ilist,j)
2456            do k=1,3
2457            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2458      &     *2.0
2459            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2460      &              rlocshield
2461      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2462            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2463            enddo
2464           enddo
2465
2466           do k=1,3
2467             gshieldc(k,i)=gshieldc(k,i)+
2468      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2469             gshieldc(k,j)=gshieldc(k,j)+
2470      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2471             gshieldc(k,i-1)=gshieldc(k,i-1)+
2472      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2473             gshieldc(k,j-1)=gshieldc(k,j-1)+
2474      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2475
2476            enddo
2477            endif
2478
2479           do k=1,3
2480             ghalf=0.5D0*ggg(k)
2481             gelc(k,i)=gelc(k,i)+ghalf
2482             gelc(k,j)=gelc(k,j)+ghalf
2483           enddo
2484 *
2485 * Loop over residues i+1 thru j-1.
2486 *
2487           do k=i+1,j-1
2488             do l=1,3
2489               gelc(l,k)=gelc(l,k)+ggg(l)
2490             enddo
2491           enddo
2492 C          ggg(1)=facvdw*xj
2493 C          ggg(2)=facvdw*yj
2494 C          ggg(3)=facvdw*zj
2495           if (sss.gt.0.0) then
2496           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2497           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2498           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2499           else
2500           ggg(1)=0.0
2501           ggg(2)=0.0
2502           ggg(3)=0.0
2503           endif
2504           do k=1,3
2505             ghalf=0.5D0*ggg(k)
2506             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2507             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2508           enddo
2509 *
2510 * Loop over residues i+1 thru j-1.
2511 *
2512           do k=i+1,j-1
2513             do l=1,3
2514               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2515             enddo
2516           enddo
2517 #else
2518           facvdw=(ev1+evdwij)*sss
2519           facel=el1+eesij
2520           fac1=fac
2521           fac=-3*rrmij*(facvdw+facvdw+facel)
2522           erij(1)=xj*rmij
2523           erij(2)=yj*rmij
2524           erij(3)=zj*rmij
2525           if (calc_grad) then
2526 *
2527 * Radial derivatives. First process both termini of the fragment (i,j)
2528 *
2529           ggg(1)=fac*xj
2530           ggg(2)=fac*yj
2531           ggg(3)=fac*zj
2532           do k=1,3
2533             ghalf=0.5D0*ggg(k)
2534             gelc(k,i)=gelc(k,i)+ghalf
2535             gelc(k,j)=gelc(k,j)+ghalf
2536           enddo
2537 *
2538 * Loop over residues i+1 thru j-1.
2539 *
2540           do k=i+1,j-1
2541             do l=1,3
2542               gelc(l,k)=gelc(l,k)+ggg(l)
2543             enddo
2544           enddo
2545 #endif
2546 *
2547 * Angular part
2548 *
2549           ecosa=2.0D0*fac3*fac1+fac4
2550           fac4=-3.0D0*fac4
2551           fac3=-6.0D0*fac3
2552           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2553           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2554           do k=1,3
2555             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2556             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2557           enddo
2558 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2559 cd   &          (dcosg(k),k=1,3)
2560           do k=1,3
2561             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2562      &      *fac_shield(i)**2*fac_shield(j)**2
2563           enddo
2564           do k=1,3
2565             ghalf=0.5D0*ggg(k)
2566             gelc(k,i)=gelc(k,i)+ghalf
2567      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2568      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2569      &           *fac_shield(i)**2*fac_shield(j)**2
2570
2571             gelc(k,j)=gelc(k,j)+ghalf
2572      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2573      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2574      &           *fac_shield(i)**2*fac_shield(j)**2
2575           enddo
2576           do k=i+1,j-1
2577             do l=1,3
2578               gelc(l,k)=gelc(l,k)+ggg(l)
2579             enddo
2580           enddo
2581           endif
2582
2583           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2584      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2585      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2586 C
2587 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2588 C   energy of a peptide unit is assumed in the form of a second-order
2589 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2590 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2591 C   are computed for EVERY pair of non-contiguous peptide groups.
2592 C
2593           if (j.lt.nres-1) then
2594             j1=j+1
2595             j2=j-1
2596           else
2597             j1=j-1
2598             j2=j-2
2599           endif
2600           kkk=0
2601           do k=1,2
2602             do l=1,2
2603               kkk=kkk+1
2604               muij(kkk)=mu(k,i)*mu(l,j)
2605             enddo
2606           enddo
2607 cd         write (iout,*) 'EELEC: i',i,' j',j
2608 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2609 cd          write(iout,*) 'muij',muij
2610           ury=scalar(uy(1,i),erij)
2611           urz=scalar(uz(1,i),erij)
2612           vry=scalar(uy(1,j),erij)
2613           vrz=scalar(uz(1,j),erij)
2614           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2615           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2616           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2617           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2618 C For diagnostics only
2619 cd          a22=1.0d0
2620 cd          a23=1.0d0
2621 cd          a32=1.0d0
2622 cd          a33=1.0d0
2623           fac=dsqrt(-ael6i)*r3ij
2624 cd          write (2,*) 'fac=',fac
2625 C For diagnostics only
2626 cd          fac=1.0d0
2627           a22=a22*fac
2628           a23=a23*fac
2629           a32=a32*fac
2630           a33=a33*fac
2631 cd          write (iout,'(4i5,4f10.5)')
2632 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2633 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2634 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2635 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2636 cd          write (iout,'(4f10.5)')
2637 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2638 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2639 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2640 cd           write (iout,'(2i3,9f10.5/)') i,j,
2641 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2642           if (calc_grad) then
2643 C Derivatives of the elements of A in virtual-bond vectors
2644           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2645 cd          do k=1,3
2646 cd            do l=1,3
2647 cd              erder(k,l)=0.0d0
2648 cd            enddo
2649 cd          enddo
2650           do k=1,3
2651             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2652             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2653             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2654             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2655             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2656             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2657             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2658             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2659             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2660             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2661             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2662             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2663           enddo
2664 cd          do k=1,3
2665 cd            do l=1,3
2666 cd              uryg(k,l)=0.0d0
2667 cd              urzg(k,l)=0.0d0
2668 cd              vryg(k,l)=0.0d0
2669 cd              vrzg(k,l)=0.0d0
2670 cd            enddo
2671 cd          enddo
2672 C Compute radial contributions to the gradient
2673           facr=-3.0d0*rrmij
2674           a22der=a22*facr
2675           a23der=a23*facr
2676           a32der=a32*facr
2677           a33der=a33*facr
2678 cd          a22der=0.0d0
2679 cd          a23der=0.0d0
2680 cd          a32der=0.0d0
2681 cd          a33der=0.0d0
2682           agg(1,1)=a22der*xj
2683           agg(2,1)=a22der*yj
2684           agg(3,1)=a22der*zj
2685           agg(1,2)=a23der*xj
2686           agg(2,2)=a23der*yj
2687           agg(3,2)=a23der*zj
2688           agg(1,3)=a32der*xj
2689           agg(2,3)=a32der*yj
2690           agg(3,3)=a32der*zj
2691           agg(1,4)=a33der*xj
2692           agg(2,4)=a33der*yj
2693           agg(3,4)=a33der*zj
2694 C Add the contributions coming from er
2695           fac3=-3.0d0*fac
2696           do k=1,3
2697             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2698             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2699             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2700             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2701           enddo
2702           do k=1,3
2703 C Derivatives in DC(i)
2704             ghalf1=0.5d0*agg(k,1)
2705             ghalf2=0.5d0*agg(k,2)
2706             ghalf3=0.5d0*agg(k,3)
2707             ghalf4=0.5d0*agg(k,4)
2708             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2709      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2710             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2711      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2712             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2713      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2714             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2715      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2716 C Derivatives in DC(i+1)
2717             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2718      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2719             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2720      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2721             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2722      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2723             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2724      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2725 C Derivatives in DC(j)
2726             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2727      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2728             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2729      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2730             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2731      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2732             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2733      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2734 C Derivatives in DC(j+1) or DC(nres-1)
2735             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2736      &      -3.0d0*vryg(k,3)*ury)
2737             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2738      &      -3.0d0*vrzg(k,3)*ury)
2739             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2740      &      -3.0d0*vryg(k,3)*urz)
2741             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2742      &      -3.0d0*vrzg(k,3)*urz)
2743 cd            aggi(k,1)=ghalf1
2744 cd            aggi(k,2)=ghalf2
2745 cd            aggi(k,3)=ghalf3
2746 cd            aggi(k,4)=ghalf4
2747 C Derivatives in DC(i+1)
2748 cd            aggi1(k,1)=agg(k,1)
2749 cd            aggi1(k,2)=agg(k,2)
2750 cd            aggi1(k,3)=agg(k,3)
2751 cd            aggi1(k,4)=agg(k,4)
2752 C Derivatives in DC(j)
2753 cd            aggj(k,1)=ghalf1
2754 cd            aggj(k,2)=ghalf2
2755 cd            aggj(k,3)=ghalf3
2756 cd            aggj(k,4)=ghalf4
2757 C Derivatives in DC(j+1)
2758 cd            aggj1(k,1)=0.0d0
2759 cd            aggj1(k,2)=0.0d0
2760 cd            aggj1(k,3)=0.0d0
2761 cd            aggj1(k,4)=0.0d0
2762             if (j.eq.nres-1 .and. i.lt.j-2) then
2763               do l=1,4
2764                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2765 cd                aggj1(k,l)=agg(k,l)
2766               enddo
2767             endif
2768           enddo
2769           endif
2770 c          goto 11111
2771 C Check the loc-el terms by numerical integration
2772           acipa(1,1)=a22
2773           acipa(1,2)=a23
2774           acipa(2,1)=a32
2775           acipa(2,2)=a33
2776           a22=-a22
2777           a23=-a23
2778           do l=1,2
2779             do k=1,3
2780               agg(k,l)=-agg(k,l)
2781               aggi(k,l)=-aggi(k,l)
2782               aggi1(k,l)=-aggi1(k,l)
2783               aggj(k,l)=-aggj(k,l)
2784               aggj1(k,l)=-aggj1(k,l)
2785             enddo
2786           enddo
2787           if (j.lt.nres-1) then
2788             a22=-a22
2789             a32=-a32
2790             do l=1,3,2
2791               do k=1,3
2792                 agg(k,l)=-agg(k,l)
2793                 aggi(k,l)=-aggi(k,l)
2794                 aggi1(k,l)=-aggi1(k,l)
2795                 aggj(k,l)=-aggj(k,l)
2796                 aggj1(k,l)=-aggj1(k,l)
2797               enddo
2798             enddo
2799           else
2800             a22=-a22
2801             a23=-a23
2802             a32=-a32
2803             a33=-a33
2804             do l=1,4
2805               do k=1,3
2806                 agg(k,l)=-agg(k,l)
2807                 aggi(k,l)=-aggi(k,l)
2808                 aggi1(k,l)=-aggi1(k,l)
2809                 aggj(k,l)=-aggj(k,l)
2810                 aggj1(k,l)=-aggj1(k,l)
2811               enddo
2812             enddo
2813           endif
2814           ENDIF ! WCORR
2815 11111     continue
2816           IF (wel_loc.gt.0.0d0) THEN
2817 C Contribution to the local-electrostatic energy coming from the i-j pair
2818           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2819      &     +a33*muij(4)
2820           if (shield_mode.eq.0) then
2821            fac_shield(i)=1.0
2822            fac_shield(j)=1.0
2823 C          else
2824 C           fac_shield(i)=0.4
2825 C           fac_shield(j)=0.6
2826           endif
2827           eel_loc_ij=eel_loc_ij
2828      &    *fac_shield(i)*fac_shield(j)
2829      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2830 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2831 C          write (iout,'(a6,2i5,0pf7.3)')
2832 C     &            'eelloc',i,j,eel_loc_ij
2833 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2834 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2835 C          eel_loc=eel_loc+eel_loc_ij
2836           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2837      &  (shield_mode.gt.0)) then
2838 C          print *,i,j
2839
2840           do ilist=1,ishield_list(i)
2841            iresshield=shield_list(ilist,i)
2842            do k=1,3
2843            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2844      &                                          /fac_shield(i)
2845 C     &      *2.0
2846            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2847      &              rlocshield
2848      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2849             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2850      &      +rlocshield
2851            enddo
2852           enddo
2853           do ilist=1,ishield_list(j)
2854            iresshield=shield_list(ilist,j)
2855            do k=1,3
2856            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2857      &                                       /fac_shield(j)
2858 C     &     *2.0
2859            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2860      &              rlocshield
2861      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2862            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2863      &             +rlocshield
2864
2865            enddo
2866           enddo
2867           do k=1,3
2868             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2869      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2870             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2871      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2872             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2873      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2874             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2875      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2876            enddo
2877            endif
2878           eel_loc=eel_loc+eel_loc_ij
2879
2880 C Partial derivatives in virtual-bond dihedral angles gamma
2881           if (calc_grad) then
2882           if (i.gt.1)
2883      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2884      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2885      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
2886      &    *fac_shield(i)*fac_shield(j)
2887      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2888
2889           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2890      &            (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2891      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
2892      &    *fac_shield(i)*fac_shield(j)
2893      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2894
2895 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2896 cd          write(iout,*) 'agg  ',agg
2897 cd          write(iout,*) 'aggi ',aggi
2898 cd          write(iout,*) 'aggi1',aggi1
2899 cd          write(iout,*) 'aggj ',aggj
2900 cd          write(iout,*) 'aggj1',aggj1
2901
2902 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2903           do l=1,3
2904             ggg(l)=(agg(l,1)*muij(1)+
2905      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
2906      &    *fac_shield(i)*fac_shield(j)
2907      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2908
2909           enddo
2910           do k=i+2,j2
2911             do l=1,3
2912               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2913             enddo
2914           enddo
2915 C Remaining derivatives of eello
2916           do l=1,3
2917             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
2918      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
2919      &    *fac_shield(i)*fac_shield(j)
2920      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2921
2922             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
2923      &         aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
2924      &    *fac_shield(i)*fac_shield(j)
2925      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2926
2927             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
2928      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
2929      &    *fac_shield(i)*fac_shield(j)
2930      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2931
2932             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
2933      &         aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
2934      &    *fac_shield(i)*fac_shield(j)
2935      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2936
2937           enddo
2938           endif
2939           ENDIF
2940           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2941 C Contributions from turns
2942             a_temp(1,1)=a22
2943             a_temp(1,2)=a23
2944             a_temp(2,1)=a32
2945             a_temp(2,2)=a33
2946             call eturn34(i,j,eello_turn3,eello_turn4)
2947           endif
2948 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2949           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2950 C
2951 C Calculate the contact function. The ith column of the array JCONT will
2952 C contain the numbers of atoms that make contacts with the atom I (of numbers
2953 C greater than I). The arrays FACONT and GACONT will contain the values of
2954 C the contact function and its derivative.
2955 c           r0ij=1.02D0*rpp(iteli,itelj)
2956 c           r0ij=1.11D0*rpp(iteli,itelj)
2957             r0ij=2.20D0*rpp(iteli,itelj)
2958 c           r0ij=1.55D0*rpp(iteli,itelj)
2959             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2960             if (fcont.gt.0.0D0) then
2961               num_conti=num_conti+1
2962               if (num_conti.gt.maxconts) then
2963                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2964      &                         ' will skip next contacts for this conf.'
2965               else
2966                 jcont_hb(num_conti,i)=j
2967                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2968      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2969 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2970 C  terms.
2971                 d_cont(num_conti,i)=rij
2972 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2973 C     --- Electrostatic-interaction matrix ---
2974                 a_chuj(1,1,num_conti,i)=a22
2975                 a_chuj(1,2,num_conti,i)=a23
2976                 a_chuj(2,1,num_conti,i)=a32
2977                 a_chuj(2,2,num_conti,i)=a33
2978 C     --- Gradient of rij
2979                 do kkk=1,3
2980                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2981                 enddo
2982 c             if (i.eq.1) then
2983 c                a_chuj(1,1,num_conti,i)=-0.61d0
2984 c                a_chuj(1,2,num_conti,i)= 0.4d0
2985 c                a_chuj(2,1,num_conti,i)= 0.65d0
2986 c                a_chuj(2,2,num_conti,i)= 0.50d0
2987 c             else if (i.eq.2) then
2988 c                a_chuj(1,1,num_conti,i)= 0.0d0
2989 c                a_chuj(1,2,num_conti,i)= 0.0d0
2990 c                a_chuj(2,1,num_conti,i)= 0.0d0
2991 c                a_chuj(2,2,num_conti,i)= 0.0d0
2992 c             endif
2993 C     --- and its gradients
2994 cd                write (iout,*) 'i',i,' j',j
2995 cd                do kkk=1,3
2996 cd                write (iout,*) 'iii 1 kkk',kkk
2997 cd                write (iout,*) agg(kkk,:)
2998 cd                enddo
2999 cd                do kkk=1,3
3000 cd                write (iout,*) 'iii 2 kkk',kkk
3001 cd                write (iout,*) aggi(kkk,:)
3002 cd                enddo
3003 cd                do kkk=1,3
3004 cd                write (iout,*) 'iii 3 kkk',kkk
3005 cd                write (iout,*) aggi1(kkk,:)
3006 cd                enddo
3007 cd                do kkk=1,3
3008 cd                write (iout,*) 'iii 4 kkk',kkk
3009 cd                write (iout,*) aggj(kkk,:)
3010 cd                enddo
3011 cd                do kkk=1,3
3012 cd                write (iout,*) 'iii 5 kkk',kkk
3013 cd                write (iout,*) aggj1(kkk,:)
3014 cd                enddo
3015                 kkll=0
3016                 do k=1,2
3017                   do l=1,2
3018                     kkll=kkll+1
3019                     do m=1,3
3020                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3021                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3022                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3023                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3024                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3025 c                      do mm=1,5
3026 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
3027 c                      enddo
3028                     enddo
3029                   enddo
3030                 enddo
3031                 ENDIF
3032                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3033 C Calculate contact energies
3034                 cosa4=4.0D0*cosa
3035                 wij=cosa-3.0D0*cosb*cosg
3036                 cosbg1=cosb+cosg
3037                 cosbg2=cosb-cosg
3038 c               fac3=dsqrt(-ael6i)/r0ij**3
3039                 fac3=dsqrt(-ael6i)*r3ij
3040                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3041                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3042 c               ees0mij=0.0D0
3043                 if (shield_mode.eq.0) then
3044                 fac_shield(i)=1.0d0
3045                 fac_shield(j)=1.0d0
3046                 else
3047                 ees0plist(num_conti,i)=j
3048 C                fac_shield(i)=0.4d0
3049 C                fac_shield(j)=0.6d0
3050                 endif
3051                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3052      &          *fac_shield(i)*fac_shield(j)
3053
3054                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3055      &          *fac_shield(i)*fac_shield(j)
3056
3057 C Diagnostics. Comment out or remove after debugging!
3058 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3059 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3060 c               ees0m(num_conti,i)=0.0D0
3061 C End diagnostics.
3062 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3063 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3064                 facont_hb(num_conti,i)=fcont
3065                 if (calc_grad) then
3066 C Angular derivatives of the contact function
3067                 ees0pij1=fac3/ees0pij
3068                 ees0mij1=fac3/ees0mij
3069                 fac3p=-3.0D0*fac3*rrmij
3070                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3071                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3072 c               ees0mij1=0.0D0
3073                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3074                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3075                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3076                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3077                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3078                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3079                 ecosap=ecosa1+ecosa2
3080                 ecosbp=ecosb1+ecosb2
3081                 ecosgp=ecosg1+ecosg2
3082                 ecosam=ecosa1-ecosa2
3083                 ecosbm=ecosb1-ecosb2
3084                 ecosgm=ecosg1-ecosg2
3085 C Diagnostics
3086 c               ecosap=ecosa1
3087 c               ecosbp=ecosb1
3088 c               ecosgp=ecosg1
3089 c               ecosam=0.0D0
3090 c               ecosbm=0.0D0
3091 c               ecosgm=0.0D0
3092 C End diagnostics
3093                 fprimcont=fprimcont/rij
3094 cd              facont_hb(num_conti,i)=1.0D0
3095 C Following line is for diagnostics.
3096 cd              fprimcont=0.0D0
3097                 do k=1,3
3098                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3099                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3100                 enddo
3101                 do k=1,3
3102                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3103                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3104                 enddo
3105                 gggp(1)=gggp(1)+ees0pijp*xj
3106                 gggp(2)=gggp(2)+ees0pijp*yj
3107                 gggp(3)=gggp(3)+ees0pijp*zj
3108                 gggm(1)=gggm(1)+ees0mijp*xj
3109                 gggm(2)=gggm(2)+ees0mijp*yj
3110                 gggm(3)=gggm(3)+ees0mijp*zj
3111 C Derivatives due to the contact function
3112                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3113                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3114                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3115                 do k=1,3
3116                   ghalfp=0.5D0*gggp(k)
3117                   ghalfm=0.5D0*gggm(k)
3118                   gacontp_hb1(k,num_conti,i)=ghalfp
3119      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3120      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3121      &          *fac_shield(i)*fac_shield(j)
3122
3123                   gacontp_hb2(k,num_conti,i)=ghalfp
3124      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3125      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3126      &          *fac_shield(i)*fac_shield(j)
3127
3128                   gacontp_hb3(k,num_conti,i)=gggp(k)
3129      &          *fac_shield(i)*fac_shield(j)
3130
3131                   gacontm_hb1(k,num_conti,i)=ghalfm
3132      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3133      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3134      &          *fac_shield(i)*fac_shield(j)
3135
3136                   gacontm_hb2(k,num_conti,i)=ghalfm
3137      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3138      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3139      &          *fac_shield(i)*fac_shield(j)
3140
3141                   gacontm_hb3(k,num_conti,i)=gggm(k)
3142      &          *fac_shield(i)*fac_shield(j)
3143
3144                 enddo
3145                 endif
3146 C Diagnostics. Comment out or remove after debugging!
3147 cdiag           do k=1,3
3148 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3149 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3150 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3151 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3152 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3153 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3154 cdiag           enddo
3155               ENDIF ! wcorr
3156               endif  ! num_conti.le.maxconts
3157             endif  ! fcont.gt.0
3158           endif    ! j.gt.i+1
3159  1216     continue
3160         enddo ! j
3161         num_cont_hb(i)=num_conti
3162  1215   continue
3163       enddo   ! i
3164 cd      do i=1,nres
3165 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3166 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3167 cd      enddo
3168 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3169 ccc      eel_loc=eel_loc+eello_turn3
3170       return
3171       end
3172 C-----------------------------------------------------------------------------
3173       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3174 C Third- and fourth-order contributions from turns
3175       implicit real*8 (a-h,o-z)
3176       include 'DIMENSIONS'
3177       include 'DIMENSIONS.ZSCOPT'
3178       include 'COMMON.IOUNITS'
3179       include 'COMMON.GEO'
3180       include 'COMMON.VAR'
3181       include 'COMMON.LOCAL'
3182       include 'COMMON.CHAIN'
3183       include 'COMMON.DERIV'
3184       include 'COMMON.INTERACT'
3185       include 'COMMON.CONTACTS'
3186       include 'COMMON.TORSION'
3187       include 'COMMON.VECTORS'
3188       include 'COMMON.FFIELD'
3189       include 'COMMON.SHIELD'
3190       include 'COMMON.CONTROL'
3191       dimension ggg(3)
3192       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3193      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3194      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3195       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3196      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3197       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3198           zj=(c(3,j)+c(3,j+1))/2.0d0
3199 C          xj=mod(xj,boxxsize)
3200 C          if (xj.lt.0) xj=xj+boxxsize
3201 C          yj=mod(yj,boxysize)
3202 C          if (yj.lt.0) yj=yj+boxysize
3203           zj=mod(zj,boxzsize)
3204           if (zj.lt.0) zj=zj+boxzsize
3205 C          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3206        if ((zj.gt.bordlipbot)
3207      &.and.(zj.lt.bordliptop)) then
3208 C the energy transfer exist
3209         if (zj.lt.buflipbot) then
3210 C what fraction I am in
3211          fracinbuf=1.0d0-
3212      &        ((zj-bordlipbot)/lipbufthick)
3213 C lipbufthick is thickenes of lipid buffore
3214          sslipj=sscalelip(fracinbuf)
3215          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3216         elseif (zj.gt.bufliptop) then
3217          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3218          sslipj=sscalelip(fracinbuf)
3219          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3220         else
3221          sslipj=1.0d0
3222          ssgradlipj=0.0
3223         endif
3224        else
3225          sslipj=0.0d0
3226          ssgradlipj=0.0
3227        endif
3228
3229       if (j.eq.i+2) then
3230       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3231 C changes suggested by Ana to avoid out of bounds
3232 C     & .or.((i+5).gt.nres)
3233 C     & .or.((i-1).le.0)
3234 C end of changes suggested by Ana
3235      &    .or. itype(i+2).eq.ntyp1
3236      &    .or. itype(i+3).eq.ntyp1
3237 C     &    .or. itype(i+5).eq.ntyp1
3238 C     &    .or. itype(i).eq.ntyp1
3239 C     &    .or. itype(i-1).eq.ntyp1
3240      &    ) goto 179
3241
3242 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3243 C
3244 C               Third-order contributions
3245 C
3246 C                 (i+2)o----(i+3)
3247 C                      | |
3248 C                      | |
3249 C                 (i+1)o----i
3250 C
3251 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3252 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3253         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3254         call transpose2(auxmat(1,1),auxmat1(1,1))
3255         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3256         if (shield_mode.eq.0) then
3257         fac_shield(i)=1.0
3258         fac_shield(j)=1.0
3259 C        else
3260 C        fac_shield(i)=0.4
3261 C        fac_shield(j)=0.6
3262         endif
3263
3264         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3265      &  *fac_shield(i)*fac_shield(j)
3266      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3267
3268         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3269      &  *fac_shield(i)*fac_shield(j)
3270      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3271
3272 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3273 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3274 cd     &    ' eello_turn3_num',4*eello_turn3_num
3275         if (calc_grad) then
3276 C Derivatives in shield mode
3277           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3278      &  (shield_mode.gt.0)) then
3279 C          print *,i,j
3280
3281           do ilist=1,ishield_list(i)
3282            iresshield=shield_list(ilist,i)
3283            do k=1,3
3284            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3285 C     &      *2.0
3286            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3287      &              rlocshield
3288      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3289             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3290      &      +rlocshield
3291            enddo
3292           enddo
3293           do ilist=1,ishield_list(j)
3294            iresshield=shield_list(ilist,j)
3295            do k=1,3
3296            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3297 C     &     *2.0
3298            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3299      &              rlocshield
3300      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3301            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3302      &             +rlocshield
3303
3304            enddo
3305           enddo
3306
3307           do k=1,3
3308             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3309      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3310             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3311      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3312             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3313      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3314             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3315      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3316            enddo
3317            endif
3318
3319 C Derivatives in gamma(i)
3320         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3321         call transpose2(auxmat2(1,1),pizda(1,1))
3322         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3323         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3324      &   *fac_shield(i)*fac_shield(j)
3325      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3326
3327 C Derivatives in gamma(i+1)
3328         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3329         call transpose2(auxmat2(1,1),pizda(1,1))
3330         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3331         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3332      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3333      &   *fac_shield(i)*fac_shield(j)
3334      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3335
3336 C Cartesian derivatives
3337         do l=1,3
3338           a_temp(1,1)=aggi(l,1)
3339           a_temp(1,2)=aggi(l,2)
3340           a_temp(2,1)=aggi(l,3)
3341           a_temp(2,2)=aggi(l,4)
3342           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3343           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3344      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3345      &   *fac_shield(i)*fac_shield(j)
3346      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3347
3348           a_temp(1,1)=aggi1(l,1)
3349           a_temp(1,2)=aggi1(l,2)
3350           a_temp(2,1)=aggi1(l,3)
3351           a_temp(2,2)=aggi1(l,4)
3352           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3353           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3354      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3355      &   *fac_shield(i)*fac_shield(j)
3356      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3357
3358           a_temp(1,1)=aggj(l,1)
3359           a_temp(1,2)=aggj(l,2)
3360           a_temp(2,1)=aggj(l,3)
3361           a_temp(2,2)=aggj(l,4)
3362           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3363           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3364      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3365      &   *fac_shield(i)*fac_shield(j)
3366      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3367
3368           a_temp(1,1)=aggj1(l,1)
3369           a_temp(1,2)=aggj1(l,2)
3370           a_temp(2,1)=aggj1(l,3)
3371           a_temp(2,2)=aggj1(l,4)
3372           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3373           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3374      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3375      &   *fac_shield(i)*fac_shield(j)
3376      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3377
3378         enddo
3379         endif
3380   179 continue
3381       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3382       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3383 C changes suggested by Ana to avoid out of bounds
3384 C     & .or.((i+5).gt.nres)
3385 C     & .or.((i-1).le.0)
3386 C end of changes suggested by Ana
3387      &    .or. itype(i+3).eq.ntyp1
3388      &    .or. itype(i+4).eq.ntyp1
3389 C     &    .or. itype(i+5).eq.ntyp1
3390      &    .or. itype(i).eq.ntyp1
3391 C     &    .or. itype(i-1).eq.ntyp1
3392      &    ) goto 178
3393 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3394 C
3395 C               Fourth-order contributions
3396 C
3397 C                 (i+3)o----(i+4)
3398 C                     /  |
3399 C               (i+2)o   |
3400 C                     \  |
3401 C                 (i+1)o----i
3402 C
3403 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3404 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3405         iti1=itortyp(itype(i+1))
3406         iti2=itortyp(itype(i+2))
3407         iti3=itortyp(itype(i+3))
3408         call transpose2(EUg(1,1,i+1),e1t(1,1))
3409         call transpose2(Eug(1,1,i+2),e2t(1,1))
3410         call transpose2(Eug(1,1,i+3),e3t(1,1))
3411         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3412         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3413         s1=scalar2(b1(1,iti2),auxvec(1))
3414         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3415         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3416         s2=scalar2(b1(1,iti1),auxvec(1))
3417         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3418         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3419         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3420         if (shield_mode.eq.0) then
3421         fac_shield(i)=1.0
3422         fac_shield(j)=1.0
3423 C        else
3424 C        fac_shield(i)=0.4
3425 C        fac_shield(j)=0.6
3426         endif
3427
3428         eello_turn4=eello_turn4-(s1+s2+s3)
3429      &  *fac_shield(i)*fac_shield(j)
3430         eello_t4=-(s1+s2+s3)
3431      &  *fac_shield(i)*fac_shield(j)
3432
3433 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3434 cd     &    ' eello_turn4_num',8*eello_turn4_num
3435 C Derivatives in gamma(i)
3436         if (calc_grad) then
3437           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3438      &  (shield_mode.gt.0)) then
3439 C          print *,i,j
3440
3441           do ilist=1,ishield_list(i)
3442            iresshield=shield_list(ilist,i)
3443            do k=1,3
3444            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3445 C     &      *2.0
3446            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3447      &              rlocshield
3448      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3449             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3450      &      +rlocshield
3451            enddo
3452           enddo
3453           do ilist=1,ishield_list(j)
3454            iresshield=shield_list(ilist,j)
3455            do k=1,3
3456            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3457 C     &     *2.0
3458            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3459      &              rlocshield
3460      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3461            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3462      &             +rlocshield
3463
3464            enddo
3465           enddo
3466
3467           do k=1,3
3468             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3469      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3470             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3471      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3472             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3473      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3474             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3475      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3476            enddo
3477            endif
3478         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3479         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3480         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3481         s1=scalar2(b1(1,iti2),auxvec(1))
3482         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3483         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3484         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3485      &  *fac_shield(i)*fac_shield(j)
3486      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3487
3488 C Derivatives in gamma(i+1)
3489         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3490         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3491         s2=scalar2(b1(1,iti1),auxvec(1))
3492         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3493         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3494         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3495         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3496      &  *fac_shield(i)*fac_shield(j)
3497      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3498
3499 C Derivatives in gamma(i+2)
3500         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3501         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3502         s1=scalar2(b1(1,iti2),auxvec(1))
3503         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3504         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3505         s2=scalar2(b1(1,iti1),auxvec(1))
3506         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3507         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3508         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3509         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3510      &  *fac_shield(i)*fac_shield(j)
3511      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3512
3513 C Cartesian derivatives
3514
3515 C Derivatives of this turn contributions in DC(i+2)
3516         if (j.lt.nres-1) then
3517           do l=1,3
3518             a_temp(1,1)=agg(l,1)
3519             a_temp(1,2)=agg(l,2)
3520             a_temp(2,1)=agg(l,3)
3521             a_temp(2,2)=agg(l,4)
3522             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3523             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3524             s1=scalar2(b1(1,iti2),auxvec(1))
3525             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3526             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3527             s2=scalar2(b1(1,iti1),auxvec(1))
3528             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3529             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3530             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3531             ggg(l)=-(s1+s2+s3)
3532             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3533      &  *fac_shield(i)*fac_shield(j)
3534      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3535
3536           enddo
3537         endif
3538 C Remaining derivatives of this turn contribution
3539         do l=1,3
3540           a_temp(1,1)=aggi(l,1)
3541           a_temp(1,2)=aggi(l,2)
3542           a_temp(2,1)=aggi(l,3)
3543           a_temp(2,2)=aggi(l,4)
3544           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3545           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3546           s1=scalar2(b1(1,iti2),auxvec(1))
3547           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3548           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3549           s2=scalar2(b1(1,iti1),auxvec(1))
3550           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3551           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3552           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3553           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3554      &  *fac_shield(i)*fac_shield(j)
3555      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3556
3557           a_temp(1,1)=aggi1(l,1)
3558           a_temp(1,2)=aggi1(l,2)
3559           a_temp(2,1)=aggi1(l,3)
3560           a_temp(2,2)=aggi1(l,4)
3561           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3562           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3563           s1=scalar2(b1(1,iti2),auxvec(1))
3564           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3565           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3566           s2=scalar2(b1(1,iti1),auxvec(1))
3567           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3568           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3569           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3570           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3571      &  *fac_shield(i)*fac_shield(j)
3572      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3573
3574           a_temp(1,1)=aggj(l,1)
3575           a_temp(1,2)=aggj(l,2)
3576           a_temp(2,1)=aggj(l,3)
3577           a_temp(2,2)=aggj(l,4)
3578           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3579           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3580           s1=scalar2(b1(1,iti2),auxvec(1))
3581           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3582           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3583           s2=scalar2(b1(1,iti1),auxvec(1))
3584           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3585           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3586           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3587           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3588      &  *fac_shield(i)*fac_shield(j)
3589      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3590
3591           a_temp(1,1)=aggj1(l,1)
3592           a_temp(1,2)=aggj1(l,2)
3593           a_temp(2,1)=aggj1(l,3)
3594           a_temp(2,2)=aggj1(l,4)
3595           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3596           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3597           s1=scalar2(b1(1,iti2),auxvec(1))
3598           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3599           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3600           s2=scalar2(b1(1,iti1),auxvec(1))
3601           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3602           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3603           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3604           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3605      &  *fac_shield(i)*fac_shield(j)
3606      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3607
3608         enddo
3609          gshieldc_t4(3,i)=gshieldc_t4(3,i)+
3610      &     ssgradlipi*eello_t4/4.0d0*lipscale
3611          gshieldc_t4(3,j)=gshieldc_t4(3,j)+
3612      &     ssgradlipj*eello_t4/4.0d0*lipscale
3613          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
3614      &     ssgradlipi*eello_t4/4.0d0*lipscale
3615          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
3616      &     ssgradlipj*eello_t4/4.0d0*lipscale
3617         endif
3618  178  continue
3619       endif
3620       return
3621       end
3622 C-----------------------------------------------------------------------------
3623       subroutine vecpr(u,v,w)
3624       implicit real*8(a-h,o-z)
3625       dimension u(3),v(3),w(3)
3626       w(1)=u(2)*v(3)-u(3)*v(2)
3627       w(2)=-u(1)*v(3)+u(3)*v(1)
3628       w(3)=u(1)*v(2)-u(2)*v(1)
3629       return
3630       end
3631 C-----------------------------------------------------------------------------
3632       subroutine unormderiv(u,ugrad,unorm,ungrad)
3633 C This subroutine computes the derivatives of a normalized vector u, given
3634 C the derivatives computed without normalization conditions, ugrad. Returns
3635 C ungrad.
3636       implicit none
3637       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3638       double precision vec(3)
3639       double precision scalar
3640       integer i,j
3641 c      write (2,*) 'ugrad',ugrad
3642 c      write (2,*) 'u',u
3643       do i=1,3
3644         vec(i)=scalar(ugrad(1,i),u(1))
3645       enddo
3646 c      write (2,*) 'vec',vec
3647       do i=1,3
3648         do j=1,3
3649           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3650         enddo
3651       enddo
3652 c      write (2,*) 'ungrad',ungrad
3653       return
3654       end
3655 C-----------------------------------------------------------------------------
3656       subroutine escp(evdw2,evdw2_14)
3657 C
3658 C This subroutine calculates the excluded-volume interaction energy between
3659 C peptide-group centers and side chains and its gradient in virtual-bond and
3660 C side-chain vectors.
3661 C
3662       implicit real*8 (a-h,o-z)
3663       include 'DIMENSIONS'
3664       include 'DIMENSIONS.ZSCOPT'
3665       include 'COMMON.GEO'
3666       include 'COMMON.VAR'
3667       include 'COMMON.LOCAL'
3668       include 'COMMON.CHAIN'
3669       include 'COMMON.DERIV'
3670       include 'COMMON.INTERACT'
3671       include 'COMMON.FFIELD'
3672       include 'COMMON.IOUNITS'
3673       dimension ggg(3)
3674       evdw2=0.0D0
3675       evdw2_14=0.0d0
3676 cd    print '(a)','Enter ESCP'
3677 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3678 c     &  ' scal14',scal14
3679       do i=iatscp_s,iatscp_e
3680         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3681         iteli=itel(i)
3682 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3683 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3684         if (iteli.eq.0) goto 1225
3685         xi=0.5D0*(c(1,i)+c(1,i+1))
3686         yi=0.5D0*(c(2,i)+c(2,i+1))
3687         zi=0.5D0*(c(3,i)+c(3,i+1))
3688 C Returning the ith atom to box
3689           xi=mod(xi,boxxsize)
3690           if (xi.lt.0) xi=xi+boxxsize
3691           yi=mod(yi,boxysize)
3692           if (yi.lt.0) yi=yi+boxysize
3693           zi=mod(zi,boxzsize)
3694           if (zi.lt.0) zi=zi+boxzsize
3695         do iint=1,nscp_gr(i)
3696
3697         do j=iscpstart(i,iint),iscpend(i,iint)
3698           itypj=iabs(itype(j))
3699           if (itypj.eq.ntyp1) cycle
3700 C Uncomment following three lines for SC-p interactions
3701 c         xj=c(1,nres+j)-xi
3702 c         yj=c(2,nres+j)-yi
3703 c         zj=c(3,nres+j)-zi
3704 C Uncomment following three lines for Ca-p interactions
3705           xj=c(1,j)
3706           yj=c(2,j)
3707           zj=c(3,j)
3708 C returning the jth atom to box
3709           xj=mod(xj,boxxsize)
3710           if (xj.lt.0) xj=xj+boxxsize
3711           yj=mod(yj,boxysize)
3712           if (yj.lt.0) yj=yj+boxysize
3713           zj=mod(zj,boxzsize)
3714           if (zj.lt.0) zj=zj+boxzsize
3715       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3716       xj_safe=xj
3717       yj_safe=yj
3718       zj_safe=zj
3719       subchap=0
3720 C Finding the closest jth atom
3721       do xshift=-1,1
3722       do yshift=-1,1
3723       do zshift=-1,1
3724           xj=xj_safe+xshift*boxxsize
3725           yj=yj_safe+yshift*boxysize
3726           zj=zj_safe+zshift*boxzsize
3727           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3728           if(dist_temp.lt.dist_init) then
3729             dist_init=dist_temp
3730             xj_temp=xj
3731             yj_temp=yj
3732             zj_temp=zj
3733             subchap=1
3734           endif
3735        enddo
3736        enddo
3737        enddo
3738        if (subchap.eq.1) then
3739           xj=xj_temp-xi
3740           yj=yj_temp-yi
3741           zj=zj_temp-zi
3742        else
3743           xj=xj_safe-xi
3744           yj=yj_safe-yi
3745           zj=zj_safe-zi
3746        endif
3747           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3748 C sss is scaling function for smoothing the cutoff gradient otherwise
3749 C the gradient would not be continuouse
3750           sss=sscale(1.0d0/(dsqrt(rrij)))
3751           if (sss.le.0.0d0) cycle
3752           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3753           fac=rrij**expon2
3754           e1=fac*fac*aad(itypj,iteli)
3755           e2=fac*bad(itypj,iteli)
3756           if (iabs(j-i) .le. 2) then
3757             e1=scal14*e1
3758             e2=scal14*e2
3759             evdw2_14=evdw2_14+(e1+e2)*sss
3760           endif
3761           evdwij=e1+e2
3762 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3763 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3764 c     &       bad(itypj,iteli)
3765           evdw2=evdw2+evdwij*sss
3766           if (calc_grad) then
3767 C
3768 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3769 C
3770           fac=-(evdwij+e1)*rrij*sss
3771           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3772           ggg(1)=xj*fac
3773           ggg(2)=yj*fac
3774           ggg(3)=zj*fac
3775           if (j.lt.i) then
3776 cd          write (iout,*) 'j<i'
3777 C Uncomment following three lines for SC-p interactions
3778 c           do k=1,3
3779 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3780 c           enddo
3781           else
3782 cd          write (iout,*) 'j>i'
3783             do k=1,3
3784               ggg(k)=-ggg(k)
3785 C Uncomment following line for SC-p interactions
3786 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3787             enddo
3788           endif
3789           do k=1,3
3790             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3791           enddo
3792           kstart=min0(i+1,j)
3793           kend=max0(i-1,j-1)
3794 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3795 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3796           do k=kstart,kend
3797             do l=1,3
3798               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3799             enddo
3800           enddo
3801           endif
3802         enddo
3803         enddo ! iint
3804  1225   continue
3805       enddo ! i
3806       do i=1,nct
3807         do j=1,3
3808           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3809           gradx_scp(j,i)=expon*gradx_scp(j,i)
3810         enddo
3811       enddo
3812 C******************************************************************************
3813 C
3814 C                              N O T E !!!
3815 C
3816 C To save time the factor EXPON has been extracted from ALL components
3817 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3818 C use!
3819 C
3820 C******************************************************************************
3821       return
3822       end
3823 C--------------------------------------------------------------------------
3824       subroutine edis(ehpb)
3825 C
3826 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3827 C
3828       implicit real*8 (a-h,o-z)
3829       include 'DIMENSIONS'
3830       include 'DIMENSIONS.ZSCOPT'
3831       include 'COMMON.SBRIDGE'
3832       include 'COMMON.CHAIN'
3833       include 'COMMON.DERIV'
3834       include 'COMMON.VAR'
3835       include 'COMMON.INTERACT'
3836       include 'COMMON.CONTROL'
3837       include 'COMMON.IOUNITS'
3838       dimension ggg(3)
3839       ehpb=0.0D0
3840 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3841 cd    print *,'link_start=',link_start,' link_end=',link_end
3842 C      write(iout,*) link_end, "link_end"
3843       if (link_end.eq.0) return
3844       do i=link_start,link_end
3845 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3846 C CA-CA distance used in regularization of structure.
3847         ii=ihpb(i)
3848         jj=jhpb(i)
3849 C iii and jjj point to the residues for which the distance is assigned.
3850         if (ii.gt.nres) then
3851           iii=ii-nres
3852           jjj=jj-nres
3853         else
3854           iii=ii
3855           jjj=jj
3856         endif
3857 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3858 C    distance and angle dependent SS bond potential.
3859 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3860 C     & iabs(itype(jjj)).eq.1) then
3861 C       write(iout,*) constr_dist,"const"
3862        if (.not.dyn_ss .and. i.le.nss) then
3863          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3864      & iabs(itype(jjj)).eq.1) then
3865           call ssbond_ene(iii,jjj,eij)
3866           ehpb=ehpb+2*eij
3867            endif !ii.gt.neres
3868         else if (ii.gt.nres .and. jj.gt.nres) then
3869 c Restraints from contact prediction
3870           dd=dist(ii,jj)
3871           if (constr_dist.eq.11) then
3872 C            ehpb=ehpb+fordepth(i)**4.0d0
3873 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3874             ehpb=ehpb+fordepth(i)**4.0d0
3875      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3876             fac=fordepth(i)**4.0d0
3877      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3878 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3879 C     &    ehpb,fordepth(i),dd
3880 C            write(iout,*) ehpb,"atu?"
3881 C            ehpb,"tu?"
3882 C            fac=fordepth(i)**4.0d0
3883 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3884            else
3885           if (dhpb1(i).gt.0.0d0) then
3886             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3887             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3888 c            write (iout,*) "beta nmr",
3889 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3890           else
3891             dd=dist(ii,jj)
3892             rdis=dd-dhpb(i)
3893 C Get the force constant corresponding to this distance.
3894             waga=forcon(i)
3895 C Calculate the contribution to energy.
3896             ehpb=ehpb+waga*rdis*rdis
3897 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3898 C
3899 C Evaluate gradient.
3900 C
3901             fac=waga*rdis/dd
3902           endif !end dhpb1(i).gt.0
3903           endif !end const_dist=11
3904           do j=1,3
3905             ggg(j)=fac*(c(j,jj)-c(j,ii))
3906           enddo
3907           do j=1,3
3908             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3909             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3910           enddo
3911           do k=1,3
3912             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3913             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3914           enddo
3915         else !ii.gt.nres
3916 C          write(iout,*) "before"
3917           dd=dist(ii,jj)
3918 C          write(iout,*) "after",dd
3919           if (constr_dist.eq.11) then
3920             ehpb=ehpb+fordepth(i)**4.0d0
3921      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3922             fac=fordepth(i)**4.0d0
3923      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3924 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3925 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3926 C            print *,ehpb,"tu?"
3927 C            write(iout,*) ehpb,"btu?",
3928 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3929 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3930 C     &    ehpb,fordepth(i),dd
3931            else
3932           if (dhpb1(i).gt.0.0d0) then
3933             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3934             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3935 c            write (iout,*) "alph nmr",
3936 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3937           else
3938             rdis=dd-dhpb(i)
3939 C Get the force constant corresponding to this distance.
3940             waga=forcon(i)
3941 C Calculate the contribution to energy.
3942             ehpb=ehpb+waga*rdis*rdis
3943 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3944 C
3945 C Evaluate gradient.
3946 C
3947             fac=waga*rdis/dd
3948           endif
3949           endif
3950
3951         do j=1,3
3952           ggg(j)=fac*(c(j,jj)-c(j,ii))
3953         enddo
3954 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3955 C If this is a SC-SC distance, we need to calculate the contributions to the
3956 C Cartesian gradient in the SC vectors (ghpbx).
3957         if (iii.lt.ii) then
3958           do j=1,3
3959             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3960             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3961           enddo
3962         endif
3963         do j=iii,jjj-1
3964           do k=1,3
3965             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3966           enddo
3967         enddo
3968         endif
3969       enddo
3970       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3971       return
3972       end
3973 C--------------------------------------------------------------------------
3974       subroutine ssbond_ene(i,j,eij)
3975 C
3976 C Calculate the distance and angle dependent SS-bond potential energy
3977 C using a free-energy function derived based on RHF/6-31G** ab initio
3978 C calculations of diethyl disulfide.
3979 C
3980 C A. Liwo and U. Kozlowska, 11/24/03
3981 C
3982       implicit real*8 (a-h,o-z)
3983       include 'DIMENSIONS'
3984       include 'DIMENSIONS.ZSCOPT'
3985       include 'COMMON.SBRIDGE'
3986       include 'COMMON.CHAIN'
3987       include 'COMMON.DERIV'
3988       include 'COMMON.LOCAL'
3989       include 'COMMON.INTERACT'
3990       include 'COMMON.VAR'
3991       include 'COMMON.IOUNITS'
3992       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3993       itypi=iabs(itype(i))
3994       xi=c(1,nres+i)
3995       yi=c(2,nres+i)
3996       zi=c(3,nres+i)
3997       dxi=dc_norm(1,nres+i)
3998       dyi=dc_norm(2,nres+i)
3999       dzi=dc_norm(3,nres+i)
4000       dsci_inv=dsc_inv(itypi)
4001       itypj=iabs(itype(j))
4002       dscj_inv=dsc_inv(itypj)
4003       xj=c(1,nres+j)-xi
4004       yj=c(2,nres+j)-yi
4005       zj=c(3,nres+j)-zi
4006       dxj=dc_norm(1,nres+j)
4007       dyj=dc_norm(2,nres+j)
4008       dzj=dc_norm(3,nres+j)
4009       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4010       rij=dsqrt(rrij)
4011       erij(1)=xj*rij
4012       erij(2)=yj*rij
4013       erij(3)=zj*rij
4014       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4015       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4016       om12=dxi*dxj+dyi*dyj+dzi*dzj
4017       do k=1,3
4018         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4019         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4020       enddo
4021       rij=1.0d0/rij
4022       deltad=rij-d0cm
4023       deltat1=1.0d0-om1
4024       deltat2=1.0d0+om2
4025       deltat12=om2-om1+2.0d0
4026       cosphi=om12-om1*om2
4027       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4028      &  +akct*deltad*deltat12
4029      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4030 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4031 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4032 c     &  " deltat12",deltat12," eij",eij
4033       ed=2*akcm*deltad+akct*deltat12
4034       pom1=akct*deltad
4035       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4036       eom1=-2*akth*deltat1-pom1-om2*pom2
4037       eom2= 2*akth*deltat2+pom1-om1*pom2
4038       eom12=pom2
4039       do k=1,3
4040         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4041       enddo
4042       do k=1,3
4043         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4044      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4045         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4046      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4047       enddo
4048 C
4049 C Calculate the components of the gradient in DC and X
4050 C
4051       do k=i,j-1
4052         do l=1,3
4053           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4054         enddo
4055       enddo
4056       return
4057       end
4058 C--------------------------------------------------------------------------
4059       subroutine ebond(estr)
4060 c
4061 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4062 c
4063       implicit real*8 (a-h,o-z)
4064       include 'DIMENSIONS'
4065       include 'DIMENSIONS.ZSCOPT'
4066       include 'COMMON.LOCAL'
4067       include 'COMMON.GEO'
4068       include 'COMMON.INTERACT'
4069       include 'COMMON.DERIV'
4070       include 'COMMON.VAR'
4071       include 'COMMON.CHAIN'
4072       include 'COMMON.IOUNITS'
4073       include 'COMMON.NAMES'
4074       include 'COMMON.FFIELD'
4075       include 'COMMON.CONTROL'
4076       logical energy_dec /.false./
4077       double precision u(3),ud(3)
4078       estr=0.0d0
4079       estr1=0.0d0
4080 c      write (iout,*) "distchainmax",distchainmax
4081       do i=nnt+1,nct
4082         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4083 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4084 C          do j=1,3
4085 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4086 C     &      *dc(j,i-1)/vbld(i)
4087 C          enddo
4088 C          if (energy_dec) write(iout,*)
4089 C     &       "estr1",i,vbld(i),distchainmax,
4090 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4091 C        else
4092          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4093         diff = vbld(i)-vbldpDUM
4094 C         write(iout,*) i,diff
4095          else
4096           diff = vbld(i)-vbldp0
4097 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4098          endif
4099           estr=estr+diff*diff
4100           do j=1,3
4101             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4102           enddo
4103 C        endif
4104 C        write (iout,'(a7,i5,4f7.3)')
4105 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4106       enddo
4107       estr=0.5d0*AKP*estr+estr1
4108 c
4109 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4110 c
4111       do i=nnt,nct
4112         iti=iabs(itype(i))
4113         if (iti.ne.10 .and. iti.ne.ntyp1) then
4114           nbi=nbondterm(iti)
4115           if (nbi.eq.1) then
4116             diff=vbld(i+nres)-vbldsc0(1,iti)
4117 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4118 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4119             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4120             do j=1,3
4121               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4122             enddo
4123           else
4124             do j=1,nbi
4125               diff=vbld(i+nres)-vbldsc0(j,iti)
4126               ud(j)=aksc(j,iti)*diff
4127               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4128             enddo
4129             uprod=u(1)
4130             do j=2,nbi
4131               uprod=uprod*u(j)
4132             enddo
4133             usum=0.0d0
4134             usumsqder=0.0d0
4135             do j=1,nbi
4136               uprod1=1.0d0
4137               uprod2=1.0d0
4138               do k=1,nbi
4139                 if (k.ne.j) then
4140                   uprod1=uprod1*u(k)
4141                   uprod2=uprod2*u(k)*u(k)
4142                 endif
4143               enddo
4144               usum=usum+uprod1
4145               usumsqder=usumsqder+ud(j)*uprod2
4146             enddo
4147 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4148 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4149             estr=estr+uprod/usum
4150             do j=1,3
4151              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4152             enddo
4153           endif
4154         endif
4155       enddo
4156       return
4157       end
4158 #ifdef CRYST_THETA
4159 C--------------------------------------------------------------------------
4160       subroutine ebend(etheta,ethetacnstr)
4161 C
4162 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4163 C angles gamma and its derivatives in consecutive thetas and gammas.
4164 C
4165       implicit real*8 (a-h,o-z)
4166       include 'DIMENSIONS'
4167       include 'DIMENSIONS.ZSCOPT'
4168       include 'COMMON.LOCAL'
4169       include 'COMMON.GEO'
4170       include 'COMMON.INTERACT'
4171       include 'COMMON.DERIV'
4172       include 'COMMON.VAR'
4173       include 'COMMON.CHAIN'
4174       include 'COMMON.IOUNITS'
4175       include 'COMMON.NAMES'
4176       include 'COMMON.FFIELD'
4177       include 'COMMON.TORCNSTR'
4178       common /calcthet/ term1,term2,termm,diffak,ratak,
4179      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4180      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4181       double precision y(2),z(2)
4182       delta=0.02d0*pi
4183 c      time11=dexp(-2*time)
4184 c      time12=1.0d0
4185       etheta=0.0D0
4186 c      write (iout,*) "nres",nres
4187 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4188 c      write (iout,*) ithet_start,ithet_end
4189       do i=ithet_start,ithet_end
4190 C        if (itype(i-1).eq.ntyp1) cycle
4191         if (i.le.2) cycle
4192         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4193      &  .or.itype(i).eq.ntyp1) cycle
4194 C Zero the energy function and its derivative at 0 or pi.
4195         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4196         it=itype(i-1)
4197         ichir1=isign(1,itype(i-2))
4198         ichir2=isign(1,itype(i))
4199          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4200          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4201          if (itype(i-1).eq.10) then
4202           itype1=isign(10,itype(i-2))
4203           ichir11=isign(1,itype(i-2))
4204           ichir12=isign(1,itype(i-2))
4205           itype2=isign(10,itype(i))
4206           ichir21=isign(1,itype(i))
4207           ichir22=isign(1,itype(i))
4208          endif
4209          if (i.eq.3) then
4210           y(1)=0.0D0
4211           y(2)=0.0D0
4212           else
4213
4214         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4215 #ifdef OSF
4216           phii=phi(i)
4217 c          icrc=0
4218 c          call proc_proc(phii,icrc)
4219           if (icrc.eq.1) phii=150.0
4220 #else
4221           phii=phi(i)
4222 #endif
4223           y(1)=dcos(phii)
4224           y(2)=dsin(phii)
4225         else
4226           y(1)=0.0D0
4227           y(2)=0.0D0
4228         endif
4229         endif
4230         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4231 #ifdef OSF
4232           phii1=phi(i+1)
4233 c          icrc=0
4234 c          call proc_proc(phii1,icrc)
4235           if (icrc.eq.1) phii1=150.0
4236           phii1=pinorm(phii1)
4237           z(1)=cos(phii1)
4238 #else
4239           phii1=phi(i+1)
4240           z(1)=dcos(phii1)
4241 #endif
4242           z(2)=dsin(phii1)
4243         else
4244           z(1)=0.0D0
4245           z(2)=0.0D0
4246         endif
4247 C Calculate the "mean" value of theta from the part of the distribution
4248 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4249 C In following comments this theta will be referred to as t_c.
4250         thet_pred_mean=0.0d0
4251         do k=1,2
4252             athetk=athet(k,it,ichir1,ichir2)
4253             bthetk=bthet(k,it,ichir1,ichir2)
4254           if (it.eq.10) then
4255              athetk=athet(k,itype1,ichir11,ichir12)
4256              bthetk=bthet(k,itype2,ichir21,ichir22)
4257           endif
4258           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4259         enddo
4260 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4261         dthett=thet_pred_mean*ssd
4262         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4263 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4264 C Derivatives of the "mean" values in gamma1 and gamma2.
4265         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4266      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4267          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4268      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4269          if (it.eq.10) then
4270       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4271      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4272         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4273      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4274          endif
4275         if (theta(i).gt.pi-delta) then
4276           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4277      &         E_tc0)
4278           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4279           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4280           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4281      &        E_theta)
4282           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4283      &        E_tc)
4284         else if (theta(i).lt.delta) then
4285           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4286           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4287           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4288      &        E_theta)
4289           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4290           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4291      &        E_tc)
4292         else
4293           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4294      &        E_theta,E_tc)
4295         endif
4296         etheta=etheta+ethetai
4297 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4298 c     &      'ebend',i,ethetai,theta(i),itype(i)
4299 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4300 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4301         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4302         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4303         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4304 c 1215   continue
4305       enddo
4306       ethetacnstr=0.0d0
4307 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4308       do i=1,ntheta_constr
4309         itheta=itheta_constr(i)
4310         thetiii=theta(itheta)
4311         difi=pinorm(thetiii-theta_constr0(i))
4312         if (difi.gt.theta_drange(i)) then
4313           difi=difi-theta_drange(i)
4314           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4315           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4316      &    +for_thet_constr(i)*difi**3
4317         else if (difi.lt.-drange(i)) then
4318           difi=difi+drange(i)
4319           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4320           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4321      &    +for_thet_constr(i)*difi**3
4322         else
4323           difi=0.0
4324         endif
4325 C       if (energy_dec) then
4326 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4327 C     &    i,itheta,rad2deg*thetiii,
4328 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4329 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4330 C     &    gloc(itheta+nphi-2,icg)
4331 C        endif
4332       enddo
4333 C Ufff.... We've done all this!!!
4334       return
4335       end
4336 C---------------------------------------------------------------------------
4337       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4338      &     E_tc)
4339       implicit real*8 (a-h,o-z)
4340       include 'DIMENSIONS'
4341       include 'COMMON.LOCAL'
4342       include 'COMMON.IOUNITS'
4343       common /calcthet/ term1,term2,termm,diffak,ratak,
4344      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4345      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4346 C Calculate the contributions to both Gaussian lobes.
4347 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4348 C The "polynomial part" of the "standard deviation" of this part of
4349 C the distribution.
4350         sig=polthet(3,it)
4351         do j=2,0,-1
4352           sig=sig*thet_pred_mean+polthet(j,it)
4353         enddo
4354 C Derivative of the "interior part" of the "standard deviation of the"
4355 C gamma-dependent Gaussian lobe in t_c.
4356         sigtc=3*polthet(3,it)
4357         do j=2,1,-1
4358           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4359         enddo
4360         sigtc=sig*sigtc
4361 C Set the parameters of both Gaussian lobes of the distribution.
4362 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4363         fac=sig*sig+sigc0(it)
4364         sigcsq=fac+fac
4365         sigc=1.0D0/sigcsq
4366 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4367         sigsqtc=-4.0D0*sigcsq*sigtc
4368 c       print *,i,sig,sigtc,sigsqtc
4369 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4370         sigtc=-sigtc/(fac*fac)
4371 C Following variable is sigma(t_c)**(-2)
4372         sigcsq=sigcsq*sigcsq
4373         sig0i=sig0(it)
4374         sig0inv=1.0D0/sig0i**2
4375         delthec=thetai-thet_pred_mean
4376         delthe0=thetai-theta0i
4377         term1=-0.5D0*sigcsq*delthec*delthec
4378         term2=-0.5D0*sig0inv*delthe0*delthe0
4379 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4380 C NaNs in taking the logarithm. We extract the largest exponent which is added
4381 C to the energy (this being the log of the distribution) at the end of energy
4382 C term evaluation for this virtual-bond angle.
4383         if (term1.gt.term2) then
4384           termm=term1
4385           term2=dexp(term2-termm)
4386           term1=1.0d0
4387         else
4388           termm=term2
4389           term1=dexp(term1-termm)
4390           term2=1.0d0
4391         endif
4392 C The ratio between the gamma-independent and gamma-dependent lobes of
4393 C the distribution is a Gaussian function of thet_pred_mean too.
4394         diffak=gthet(2,it)-thet_pred_mean
4395         ratak=diffak/gthet(3,it)**2
4396         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4397 C Let's differentiate it in thet_pred_mean NOW.
4398         aktc=ak*ratak
4399 C Now put together the distribution terms to make complete distribution.
4400         termexp=term1+ak*term2
4401         termpre=sigc+ak*sig0i
4402 C Contribution of the bending energy from this theta is just the -log of
4403 C the sum of the contributions from the two lobes and the pre-exponential
4404 C factor. Simple enough, isn't it?
4405         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4406 C NOW the derivatives!!!
4407 C 6/6/97 Take into account the deformation.
4408         E_theta=(delthec*sigcsq*term1
4409      &       +ak*delthe0*sig0inv*term2)/termexp
4410         E_tc=((sigtc+aktc*sig0i)/termpre
4411      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4412      &       aktc*term2)/termexp)
4413       return
4414       end
4415 c-----------------------------------------------------------------------------
4416       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4417       implicit real*8 (a-h,o-z)
4418       include 'DIMENSIONS'
4419       include 'COMMON.LOCAL'
4420       include 'COMMON.IOUNITS'
4421       common /calcthet/ term1,term2,termm,diffak,ratak,
4422      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4423      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4424       delthec=thetai-thet_pred_mean
4425       delthe0=thetai-theta0i
4426 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4427       t3 = thetai-thet_pred_mean
4428       t6 = t3**2
4429       t9 = term1
4430       t12 = t3*sigcsq
4431       t14 = t12+t6*sigsqtc
4432       t16 = 1.0d0
4433       t21 = thetai-theta0i
4434       t23 = t21**2
4435       t26 = term2
4436       t27 = t21*t26
4437       t32 = termexp
4438       t40 = t32**2
4439       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4440      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4441      & *(-t12*t9-ak*sig0inv*t27)
4442       return
4443       end
4444 #else
4445 C--------------------------------------------------------------------------
4446       subroutine ebend(etheta,ethetacnstr)
4447 C
4448 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4449 C angles gamma and its derivatives in consecutive thetas and gammas.
4450 C ab initio-derived potentials from
4451 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4452 C
4453       implicit real*8 (a-h,o-z)
4454       include 'DIMENSIONS'
4455       include 'DIMENSIONS.ZSCOPT'
4456       include 'COMMON.LOCAL'
4457       include 'COMMON.GEO'
4458       include 'COMMON.INTERACT'
4459       include 'COMMON.DERIV'
4460       include 'COMMON.VAR'
4461       include 'COMMON.CHAIN'
4462       include 'COMMON.IOUNITS'
4463       include 'COMMON.NAMES'
4464       include 'COMMON.FFIELD'
4465       include 'COMMON.CONTROL'
4466       include 'COMMON.TORCNSTR'
4467       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4468      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4469      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4470      & sinph1ph2(maxdouble,maxdouble)
4471       logical lprn /.false./, lprn1 /.false./
4472       etheta=0.0D0
4473 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4474       do i=ithet_start,ithet_end
4475 C         if (i.eq.2) cycle
4476 C        if (itype(i-1).eq.ntyp1) cycle
4477         if (i.le.2) cycle
4478         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4479      &  .or.itype(i).eq.ntyp1) cycle
4480         if (iabs(itype(i+1)).eq.20) iblock=2
4481         if (iabs(itype(i+1)).ne.20) iblock=1
4482         dethetai=0.0d0
4483         dephii=0.0d0
4484         dephii1=0.0d0
4485         theti2=0.5d0*theta(i)
4486         ityp2=ithetyp((itype(i-1)))
4487         do k=1,nntheterm
4488           coskt(k)=dcos(k*theti2)
4489           sinkt(k)=dsin(k*theti2)
4490         enddo
4491         if (i.eq.3) then
4492           phii=0.0d0
4493           ityp1=nthetyp+1
4494           do k=1,nsingle
4495             cosph1(k)=0.0d0
4496             sinph1(k)=0.0d0
4497           enddo
4498         else
4499         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4500 #ifdef OSF
4501           phii=phi(i)
4502           if (phii.ne.phii) phii=150.0
4503 #else
4504           phii=phi(i)
4505 #endif
4506           ityp1=ithetyp((itype(i-2)))
4507           do k=1,nsingle
4508             cosph1(k)=dcos(k*phii)
4509             sinph1(k)=dsin(k*phii)
4510           enddo
4511         else
4512           phii=0.0d0
4513 c          ityp1=nthetyp+1
4514           do k=1,nsingle
4515             ityp1=ithetyp((itype(i-2)))
4516             cosph1(k)=0.0d0
4517             sinph1(k)=0.0d0
4518           enddo
4519         endif
4520         endif
4521         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4522 #ifdef OSF
4523           phii1=phi(i+1)
4524           if (phii1.ne.phii1) phii1=150.0
4525           phii1=pinorm(phii1)
4526 #else
4527           phii1=phi(i+1)
4528 #endif
4529           ityp3=ithetyp((itype(i)))
4530           do k=1,nsingle
4531             cosph2(k)=dcos(k*phii1)
4532             sinph2(k)=dsin(k*phii1)
4533           enddo
4534         else
4535           phii1=0.0d0
4536 c          ityp3=nthetyp+1
4537           ityp3=ithetyp((itype(i)))
4538           do k=1,nsingle
4539             cosph2(k)=0.0d0
4540             sinph2(k)=0.0d0
4541           enddo
4542         endif
4543 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4544 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4545 c        call flush(iout)
4546         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4547         do k=1,ndouble
4548           do l=1,k-1
4549             ccl=cosph1(l)*cosph2(k-l)
4550             ssl=sinph1(l)*sinph2(k-l)
4551             scl=sinph1(l)*cosph2(k-l)
4552             csl=cosph1(l)*sinph2(k-l)
4553             cosph1ph2(l,k)=ccl-ssl
4554             cosph1ph2(k,l)=ccl+ssl
4555             sinph1ph2(l,k)=scl+csl
4556             sinph1ph2(k,l)=scl-csl
4557           enddo
4558         enddo
4559         if (lprn) then
4560         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4561      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4562         write (iout,*) "coskt and sinkt"
4563         do k=1,nntheterm
4564           write (iout,*) k,coskt(k),sinkt(k)
4565         enddo
4566         endif
4567         do k=1,ntheterm
4568           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4569           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4570      &      *coskt(k)
4571           if (lprn)
4572      &    write (iout,*) "k",k,"
4573      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4574      &     " ethetai",ethetai
4575         enddo
4576         if (lprn) then
4577         write (iout,*) "cosph and sinph"
4578         do k=1,nsingle
4579           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4580         enddo
4581         write (iout,*) "cosph1ph2 and sinph2ph2"
4582         do k=2,ndouble
4583           do l=1,k-1
4584             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4585      &         sinph1ph2(l,k),sinph1ph2(k,l)
4586           enddo
4587         enddo
4588         write(iout,*) "ethetai",ethetai
4589         endif
4590         do m=1,ntheterm2
4591           do k=1,nsingle
4592             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4593      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4594      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4595      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4596             ethetai=ethetai+sinkt(m)*aux
4597             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4598             dephii=dephii+k*sinkt(m)*(
4599      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4600      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4601             dephii1=dephii1+k*sinkt(m)*(
4602      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4603      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4604             if (lprn)
4605      &      write (iout,*) "m",m," k",k," bbthet",
4606      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4607      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4608      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4609      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4610           enddo
4611         enddo
4612         if (lprn)
4613      &  write(iout,*) "ethetai",ethetai
4614         do m=1,ntheterm3
4615           do k=2,ndouble
4616             do l=1,k-1
4617               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4618      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4619      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4620      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4621               ethetai=ethetai+sinkt(m)*aux
4622               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4623               dephii=dephii+l*sinkt(m)*(
4624      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4625      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4626      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4627      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4628               dephii1=dephii1+(k-l)*sinkt(m)*(
4629      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4630      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4631      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4632      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4633               if (lprn) then
4634               write (iout,*) "m",m," k",k," l",l," ffthet",
4635      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4636      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4637      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4638      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4639      &            " ethetai",ethetai
4640               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4641      &            cosph1ph2(k,l)*sinkt(m),
4642      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4643               endif
4644             enddo
4645           enddo
4646         enddo
4647 10      continue
4648         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4649      &   i,theta(i)*rad2deg,phii*rad2deg,
4650      &   phii1*rad2deg,ethetai
4651         etheta=etheta+ethetai
4652         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4653         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4654 c        gloc(nphi+i-2,icg)=wang*dethetai
4655         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4656       enddo
4657 C now constrains
4658       ethetacnstr=0.0d0
4659 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4660       do i=1,ntheta_constr
4661         itheta=itheta_constr(i)
4662         thetiii=theta(itheta)
4663         difi=pinorm(thetiii-theta_constr0(i))
4664         if (difi.gt.theta_drange(i)) then
4665           difi=difi-theta_drange(i)
4666           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4667           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4668      &    +for_thet_constr(i)*difi**3
4669         else if (difi.lt.-drange(i)) then
4670           difi=difi+drange(i)
4671           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4672           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4673      &    +for_thet_constr(i)*difi**3
4674         else
4675           difi=0.0
4676         endif
4677 C       if (energy_dec) then
4678 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4679 C     &    i,itheta,rad2deg*thetiii,
4680 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4681 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4682 C     &    gloc(itheta+nphi-2,icg)
4683 C        endif
4684       enddo
4685       return
4686       end
4687 #endif
4688 #ifdef CRYST_SC
4689 c-----------------------------------------------------------------------------
4690       subroutine esc(escloc)
4691 C Calculate the local energy of a side chain and its derivatives in the
4692 C corresponding virtual-bond valence angles THETA and the spherical angles
4693 C ALPHA and OMEGA.
4694       implicit real*8 (a-h,o-z)
4695       include 'DIMENSIONS'
4696       include 'DIMENSIONS.ZSCOPT'
4697       include 'COMMON.GEO'
4698       include 'COMMON.LOCAL'
4699       include 'COMMON.VAR'
4700       include 'COMMON.INTERACT'
4701       include 'COMMON.DERIV'
4702       include 'COMMON.CHAIN'
4703       include 'COMMON.IOUNITS'
4704       include 'COMMON.NAMES'
4705       include 'COMMON.FFIELD'
4706       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4707      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4708       common /sccalc/ time11,time12,time112,theti,it,nlobit
4709       delta=0.02d0*pi
4710       escloc=0.0D0
4711 C      write (iout,*) 'ESC'
4712       do i=loc_start,loc_end
4713         it=itype(i)
4714         if (it.eq.ntyp1) cycle
4715         if (it.eq.10) goto 1
4716         nlobit=nlob(iabs(it))
4717 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4718 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4719         theti=theta(i+1)-pipol
4720         x(1)=dtan(theti)
4721         x(2)=alph(i)
4722         x(3)=omeg(i)
4723 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4724
4725         if (x(2).gt.pi-delta) then
4726           xtemp(1)=x(1)
4727           xtemp(2)=pi-delta
4728           xtemp(3)=x(3)
4729           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4730           xtemp(2)=pi
4731           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4732           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4733      &        escloci,dersc(2))
4734           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4735      &        ddersc0(1),dersc(1))
4736           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4737      &        ddersc0(3),dersc(3))
4738           xtemp(2)=pi-delta
4739           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4740           xtemp(2)=pi
4741           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4742           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4743      &            dersc0(2),esclocbi,dersc02)
4744           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4745      &            dersc12,dersc01)
4746           call splinthet(x(2),0.5d0*delta,ss,ssd)
4747           dersc0(1)=dersc01
4748           dersc0(2)=dersc02
4749           dersc0(3)=0.0d0
4750           do k=1,3
4751             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4752           enddo
4753           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4754           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4755      &             esclocbi,ss,ssd
4756           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4757 c         escloci=esclocbi
4758 c         write (iout,*) escloci
4759         else if (x(2).lt.delta) then
4760           xtemp(1)=x(1)
4761           xtemp(2)=delta
4762           xtemp(3)=x(3)
4763           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4764           xtemp(2)=0.0d0
4765           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4766           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4767      &        escloci,dersc(2))
4768           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4769      &        ddersc0(1),dersc(1))
4770           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4771      &        ddersc0(3),dersc(3))
4772           xtemp(2)=delta
4773           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4774           xtemp(2)=0.0d0
4775           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4776           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4777      &            dersc0(2),esclocbi,dersc02)
4778           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4779      &            dersc12,dersc01)
4780           dersc0(1)=dersc01
4781           dersc0(2)=dersc02
4782           dersc0(3)=0.0d0
4783           call splinthet(x(2),0.5d0*delta,ss,ssd)
4784           do k=1,3
4785             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4786           enddo
4787           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4788 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4789 c     &             esclocbi,ss,ssd
4790           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4791 C         write (iout,*) 'i=',i, escloci
4792         else
4793           call enesc(x,escloci,dersc,ddummy,.false.)
4794         endif
4795
4796         escloc=escloc+escloci
4797 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4798             write (iout,'(a6,i5,0pf7.3)')
4799      &     'escloc',i,escloci
4800
4801         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4802      &   wscloc*dersc(1)
4803         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4804         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4805     1   continue
4806       enddo
4807       return
4808       end
4809 C---------------------------------------------------------------------------
4810       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4811       implicit real*8 (a-h,o-z)
4812       include 'DIMENSIONS'
4813       include 'COMMON.GEO'
4814       include 'COMMON.LOCAL'
4815       include 'COMMON.IOUNITS'
4816       common /sccalc/ time11,time12,time112,theti,it,nlobit
4817       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4818       double precision contr(maxlob,-1:1)
4819       logical mixed
4820 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4821         escloc_i=0.0D0
4822         do j=1,3
4823           dersc(j)=0.0D0
4824           if (mixed) ddersc(j)=0.0d0
4825         enddo
4826         x3=x(3)
4827
4828 C Because of periodicity of the dependence of the SC energy in omega we have
4829 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4830 C To avoid underflows, first compute & store the exponents.
4831
4832         do iii=-1,1
4833
4834           x(3)=x3+iii*dwapi
4835
4836           do j=1,nlobit
4837             do k=1,3
4838               z(k)=x(k)-censc(k,j,it)
4839             enddo
4840             do k=1,3
4841               Axk=0.0D0
4842               do l=1,3
4843                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4844               enddo
4845               Ax(k,j,iii)=Axk
4846             enddo
4847             expfac=0.0D0
4848             do k=1,3
4849               expfac=expfac+Ax(k,j,iii)*z(k)
4850             enddo
4851             contr(j,iii)=expfac
4852           enddo ! j
4853
4854         enddo ! iii
4855
4856         x(3)=x3
4857 C As in the case of ebend, we want to avoid underflows in exponentiation and
4858 C subsequent NaNs and INFs in energy calculation.
4859 C Find the largest exponent
4860         emin=contr(1,-1)
4861         do iii=-1,1
4862           do j=1,nlobit
4863             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4864           enddo
4865         enddo
4866         emin=0.5D0*emin
4867 cd      print *,'it=',it,' emin=',emin
4868
4869 C Compute the contribution to SC energy and derivatives
4870         do iii=-1,1
4871
4872           do j=1,nlobit
4873             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4874 cd          print *,'j=',j,' expfac=',expfac
4875             escloc_i=escloc_i+expfac
4876             do k=1,3
4877               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4878             enddo
4879             if (mixed) then
4880               do k=1,3,2
4881                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4882      &            +gaussc(k,2,j,it))*expfac
4883               enddo
4884             endif
4885           enddo
4886
4887         enddo ! iii
4888
4889         dersc(1)=dersc(1)/cos(theti)**2
4890         ddersc(1)=ddersc(1)/cos(theti)**2
4891         ddersc(3)=ddersc(3)
4892
4893         escloci=-(dlog(escloc_i)-emin)
4894         do j=1,3
4895           dersc(j)=dersc(j)/escloc_i
4896         enddo
4897         if (mixed) then
4898           do j=1,3,2
4899             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4900           enddo
4901         endif
4902       return
4903       end
4904 C------------------------------------------------------------------------------
4905       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4906       implicit real*8 (a-h,o-z)
4907       include 'DIMENSIONS'
4908       include 'COMMON.GEO'
4909       include 'COMMON.LOCAL'
4910       include 'COMMON.IOUNITS'
4911       common /sccalc/ time11,time12,time112,theti,it,nlobit
4912       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4913       double precision contr(maxlob)
4914       logical mixed
4915
4916       escloc_i=0.0D0
4917
4918       do j=1,3
4919         dersc(j)=0.0D0
4920       enddo
4921
4922       do j=1,nlobit
4923         do k=1,2
4924           z(k)=x(k)-censc(k,j,it)
4925         enddo
4926         z(3)=dwapi
4927         do k=1,3
4928           Axk=0.0D0
4929           do l=1,3
4930             Axk=Axk+gaussc(l,k,j,it)*z(l)
4931           enddo
4932           Ax(k,j)=Axk
4933         enddo
4934         expfac=0.0D0
4935         do k=1,3
4936           expfac=expfac+Ax(k,j)*z(k)
4937         enddo
4938         contr(j)=expfac
4939       enddo ! j
4940
4941 C As in the case of ebend, we want to avoid underflows in exponentiation and
4942 C subsequent NaNs and INFs in energy calculation.
4943 C Find the largest exponent
4944       emin=contr(1)
4945       do j=1,nlobit
4946         if (emin.gt.contr(j)) emin=contr(j)
4947       enddo
4948       emin=0.5D0*emin
4949
4950 C Compute the contribution to SC energy and derivatives
4951
4952       dersc12=0.0d0
4953       do j=1,nlobit
4954         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4955         escloc_i=escloc_i+expfac
4956         do k=1,2
4957           dersc(k)=dersc(k)+Ax(k,j)*expfac
4958         enddo
4959         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4960      &            +gaussc(1,2,j,it))*expfac
4961         dersc(3)=0.0d0
4962       enddo
4963
4964       dersc(1)=dersc(1)/cos(theti)**2
4965       dersc12=dersc12/cos(theti)**2
4966       escloci=-(dlog(escloc_i)-emin)
4967       do j=1,2
4968         dersc(j)=dersc(j)/escloc_i
4969       enddo
4970       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4971       return
4972       end
4973 #else
4974 c----------------------------------------------------------------------------------
4975       subroutine esc(escloc)
4976 C Calculate the local energy of a side chain and its derivatives in the
4977 C corresponding virtual-bond valence angles THETA and the spherical angles
4978 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4979 C added by Urszula Kozlowska. 07/11/2007
4980 C
4981       implicit real*8 (a-h,o-z)
4982       include 'DIMENSIONS'
4983       include 'DIMENSIONS.ZSCOPT'
4984       include 'COMMON.GEO'
4985       include 'COMMON.LOCAL'
4986       include 'COMMON.VAR'
4987       include 'COMMON.SCROT'
4988       include 'COMMON.INTERACT'
4989       include 'COMMON.DERIV'
4990       include 'COMMON.CHAIN'
4991       include 'COMMON.IOUNITS'
4992       include 'COMMON.NAMES'
4993       include 'COMMON.FFIELD'
4994       include 'COMMON.CONTROL'
4995       include 'COMMON.VECTORS'
4996       double precision x_prime(3),y_prime(3),z_prime(3)
4997      &    , sumene,dsc_i,dp2_i,x(65),
4998      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4999      &    de_dxx,de_dyy,de_dzz,de_dt
5000       double precision s1_t,s1_6_t,s2_t,s2_6_t
5001       double precision
5002      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5003      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5004      & dt_dCi(3),dt_dCi1(3)
5005       common /sccalc/ time11,time12,time112,theti,it,nlobit
5006       delta=0.02d0*pi
5007       escloc=0.0D0
5008       do i=loc_start,loc_end
5009         if (itype(i).eq.ntyp1) cycle
5010         costtab(i+1) =dcos(theta(i+1))
5011         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5012         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5013         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5014         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5015         cosfac=dsqrt(cosfac2)
5016         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5017         sinfac=dsqrt(sinfac2)
5018         it=iabs(itype(i))
5019         if (it.eq.10) goto 1
5020 c
5021 C  Compute the axes of tghe local cartesian coordinates system; store in
5022 c   x_prime, y_prime and z_prime
5023 c
5024         do j=1,3
5025           x_prime(j) = 0.00
5026           y_prime(j) = 0.00
5027           z_prime(j) = 0.00
5028         enddo
5029 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5030 C     &   dc_norm(3,i+nres)
5031         do j = 1,3
5032           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5033           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5034         enddo
5035         do j = 1,3
5036           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5037         enddo
5038 c       write (2,*) "i",i
5039 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5040 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5041 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5042 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5043 c      & " xy",scalar(x_prime(1),y_prime(1)),
5044 c      & " xz",scalar(x_prime(1),z_prime(1)),
5045 c      & " yy",scalar(y_prime(1),y_prime(1)),
5046 c      & " yz",scalar(y_prime(1),z_prime(1)),
5047 c      & " zz",scalar(z_prime(1),z_prime(1))
5048 c
5049 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5050 C to local coordinate system. Store in xx, yy, zz.
5051 c
5052         xx=0.0d0
5053         yy=0.0d0
5054         zz=0.0d0
5055         do j = 1,3
5056           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5057           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5058           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5059         enddo
5060
5061         xxtab(i)=xx
5062         yytab(i)=yy
5063         zztab(i)=zz
5064 C
5065 C Compute the energy of the ith side cbain
5066 C
5067 c        write (2,*) "xx",xx," yy",yy," zz",zz
5068         it=iabs(itype(i))
5069         do j = 1,65
5070           x(j) = sc_parmin(j,it)
5071         enddo
5072 #ifdef CHECK_COORD
5073 Cc diagnostics - remove later
5074         xx1 = dcos(alph(2))
5075         yy1 = dsin(alph(2))*dcos(omeg(2))
5076         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5077         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5078      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5079      &    xx1,yy1,zz1
5080 C,"  --- ", xx_w,yy_w,zz_w
5081 c end diagnostics
5082 #endif
5083         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5084      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5085      &   + x(10)*yy*zz
5086         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5087      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5088      & + x(20)*yy*zz
5089         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5090      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5091      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5092      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5093      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5094      &  +x(40)*xx*yy*zz
5095         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5096      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5097      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5098      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5099      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5100      &  +x(60)*xx*yy*zz
5101         dsc_i   = 0.743d0+x(61)
5102         dp2_i   = 1.9d0+x(62)
5103         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5104      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5105         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5106      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5107         s1=(1+x(63))/(0.1d0 + dscp1)
5108         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5109         s2=(1+x(65))/(0.1d0 + dscp2)
5110         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5111         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5112      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5113 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5114 c     &   sumene4,
5115 c     &   dscp1,dscp2,sumene
5116 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5117         escloc = escloc + sumene
5118 c        write (2,*) "escloc",escloc
5119 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5120 c     &  zz,xx,yy
5121         if (.not. calc_grad) goto 1
5122 #ifdef DEBUG
5123 C
5124 C This section to check the numerical derivatives of the energy of ith side
5125 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5126 C #define DEBUG in the code to turn it on.
5127 C
5128         write (2,*) "sumene               =",sumene
5129         aincr=1.0d-7
5130         xxsave=xx
5131         xx=xx+aincr
5132         write (2,*) xx,yy,zz
5133         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5134         de_dxx_num=(sumenep-sumene)/aincr
5135         xx=xxsave
5136         write (2,*) "xx+ sumene from enesc=",sumenep
5137         yysave=yy
5138         yy=yy+aincr
5139         write (2,*) xx,yy,zz
5140         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5141         de_dyy_num=(sumenep-sumene)/aincr
5142         yy=yysave
5143         write (2,*) "yy+ sumene from enesc=",sumenep
5144         zzsave=zz
5145         zz=zz+aincr
5146         write (2,*) xx,yy,zz
5147         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5148         de_dzz_num=(sumenep-sumene)/aincr
5149         zz=zzsave
5150         write (2,*) "zz+ sumene from enesc=",sumenep
5151         costsave=cost2tab(i+1)
5152         sintsave=sint2tab(i+1)
5153         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5154         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5155         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5156         de_dt_num=(sumenep-sumene)/aincr
5157         write (2,*) " t+ sumene from enesc=",sumenep
5158         cost2tab(i+1)=costsave
5159         sint2tab(i+1)=sintsave
5160 C End of diagnostics section.
5161 #endif
5162 C
5163 C Compute the gradient of esc
5164 C
5165         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5166         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5167         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5168         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5169         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5170         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5171         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5172         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5173         pom1=(sumene3*sint2tab(i+1)+sumene1)
5174      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5175         pom2=(sumene4*cost2tab(i+1)+sumene2)
5176      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5177         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5178         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5179      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5180      &  +x(40)*yy*zz
5181         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5182         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5183      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5184      &  +x(60)*yy*zz
5185         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5186      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5187      &        +(pom1+pom2)*pom_dx
5188 #ifdef DEBUG
5189         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5190 #endif
5191 C
5192         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5193         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5194      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5195      &  +x(40)*xx*zz
5196         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5197         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5198      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5199      &  +x(59)*zz**2 +x(60)*xx*zz
5200         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5201      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5202      &        +(pom1-pom2)*pom_dy
5203 #ifdef DEBUG
5204         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5205 #endif
5206 C
5207         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5208      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5209      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5210      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5211      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5212      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5213      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5214      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5215 #ifdef DEBUG
5216         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5217 #endif
5218 C
5219         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5220      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5221      &  +pom1*pom_dt1+pom2*pom_dt2
5222 #ifdef DEBUG
5223         write(2,*), "de_dt = ", de_dt,de_dt_num
5224 #endif
5225 c
5226 C
5227        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5228        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5229        cosfac2xx=cosfac2*xx
5230        sinfac2yy=sinfac2*yy
5231        do k = 1,3
5232          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5233      &      vbld_inv(i+1)
5234          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5235      &      vbld_inv(i)
5236          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5237          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5238 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5239 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5240 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5241 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5242          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5243          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5244          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5245          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5246          dZZ_Ci1(k)=0.0d0
5247          dZZ_Ci(k)=0.0d0
5248          do j=1,3
5249            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5250      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5251            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5252      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5253          enddo
5254
5255          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5256          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5257          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5258 c
5259          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5260          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5261        enddo
5262
5263        do k=1,3
5264          dXX_Ctab(k,i)=dXX_Ci(k)
5265          dXX_C1tab(k,i)=dXX_Ci1(k)
5266          dYY_Ctab(k,i)=dYY_Ci(k)
5267          dYY_C1tab(k,i)=dYY_Ci1(k)
5268          dZZ_Ctab(k,i)=dZZ_Ci(k)
5269          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5270          dXX_XYZtab(k,i)=dXX_XYZ(k)
5271          dYY_XYZtab(k,i)=dYY_XYZ(k)
5272          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5273        enddo
5274
5275        do k = 1,3
5276 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5277 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5278 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5279 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5280 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5281 c     &    dt_dci(k)
5282 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5283 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5284          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5285      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5286          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5287      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5288          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5289      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5290        enddo
5291 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5292 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5293
5294 C to check gradient call subroutine check_grad
5295
5296     1 continue
5297       enddo
5298       return
5299       end
5300 #endif
5301 c------------------------------------------------------------------------------
5302       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5303 C
5304 C This procedure calculates two-body contact function g(rij) and its derivative:
5305 C
5306 C           eps0ij                                     !       x < -1
5307 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5308 C            0                                         !       x > 1
5309 C
5310 C where x=(rij-r0ij)/delta
5311 C
5312 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5313 C
5314       implicit none
5315       double precision rij,r0ij,eps0ij,fcont,fprimcont
5316       double precision x,x2,x4,delta
5317 c     delta=0.02D0*r0ij
5318 c      delta=0.2D0*r0ij
5319       x=(rij-r0ij)/delta
5320       if (x.lt.-1.0D0) then
5321         fcont=eps0ij
5322         fprimcont=0.0D0
5323       else if (x.le.1.0D0) then
5324         x2=x*x
5325         x4=x2*x2
5326         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5327         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5328       else
5329         fcont=0.0D0
5330         fprimcont=0.0D0
5331       endif
5332       return
5333       end
5334 c------------------------------------------------------------------------------
5335       subroutine splinthet(theti,delta,ss,ssder)
5336       implicit real*8 (a-h,o-z)
5337       include 'DIMENSIONS'
5338       include 'DIMENSIONS.ZSCOPT'
5339       include 'COMMON.VAR'
5340       include 'COMMON.GEO'
5341       thetup=pi-delta
5342       thetlow=delta
5343       if (theti.gt.pipol) then
5344         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5345       else
5346         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5347         ssder=-ssder
5348       endif
5349       return
5350       end
5351 c------------------------------------------------------------------------------
5352       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5353       implicit none
5354       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5355       double precision ksi,ksi2,ksi3,a1,a2,a3
5356       a1=fprim0*delta/(f1-f0)
5357       a2=3.0d0-2.0d0*a1
5358       a3=a1-2.0d0
5359       ksi=(x-x0)/delta
5360       ksi2=ksi*ksi
5361       ksi3=ksi2*ksi
5362       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5363       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5364       return
5365       end
5366 c------------------------------------------------------------------------------
5367       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5368       implicit none
5369       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5370       double precision ksi,ksi2,ksi3,a1,a2,a3
5371       ksi=(x-x0)/delta
5372       ksi2=ksi*ksi
5373       ksi3=ksi2*ksi
5374       a1=fprim0x*delta
5375       a2=3*(f1x-f0x)-2*fprim0x*delta
5376       a3=fprim0x*delta-2*(f1x-f0x)
5377       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5378       return
5379       end
5380 C-----------------------------------------------------------------------------
5381 #ifdef CRYST_TOR
5382 C-----------------------------------------------------------------------------
5383       subroutine etor(etors,edihcnstr,fact)
5384       implicit real*8 (a-h,o-z)
5385       include 'DIMENSIONS'
5386       include 'DIMENSIONS.ZSCOPT'
5387       include 'COMMON.VAR'
5388       include 'COMMON.GEO'
5389       include 'COMMON.LOCAL'
5390       include 'COMMON.TORSION'
5391       include 'COMMON.INTERACT'
5392       include 'COMMON.DERIV'
5393       include 'COMMON.CHAIN'
5394       include 'COMMON.NAMES'
5395       include 'COMMON.IOUNITS'
5396       include 'COMMON.FFIELD'
5397       include 'COMMON.TORCNSTR'
5398       logical lprn
5399 C Set lprn=.true. for debugging
5400       lprn=.false.
5401 c      lprn=.true.
5402       etors=0.0D0
5403       do i=iphi_start,iphi_end
5404         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5405      &      .or. itype(i).eq.ntyp1) cycle
5406         itori=itortyp(itype(i-2))
5407         itori1=itortyp(itype(i-1))
5408         phii=phi(i)
5409         gloci=0.0D0
5410 C Proline-Proline pair is a special case...
5411         if (itori.eq.3 .and. itori1.eq.3) then
5412           if (phii.gt.-dwapi3) then
5413             cosphi=dcos(3*phii)
5414             fac=1.0D0/(1.0D0-cosphi)
5415             etorsi=v1(1,3,3)*fac
5416             etorsi=etorsi+etorsi
5417             etors=etors+etorsi-v1(1,3,3)
5418             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5419           endif
5420           do j=1,3
5421             v1ij=v1(j+1,itori,itori1)
5422             v2ij=v2(j+1,itori,itori1)
5423             cosphi=dcos(j*phii)
5424             sinphi=dsin(j*phii)
5425             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5426             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5427           enddo
5428         else
5429           do j=1,nterm_old
5430             v1ij=v1(j,itori,itori1)
5431             v2ij=v2(j,itori,itori1)
5432             cosphi=dcos(j*phii)
5433             sinphi=dsin(j*phii)
5434             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5435             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5436           enddo
5437         endif
5438         if (lprn)
5439      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5440      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5441      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5442         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5443 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5444       enddo
5445 ! 6/20/98 - dihedral angle constraints
5446       edihcnstr=0.0d0
5447       do i=1,ndih_constr
5448         itori=idih_constr(i)
5449         phii=phi(itori)
5450         difi=phii-phi0(i)
5451         if (difi.gt.drange(i)) then
5452           difi=difi-drange(i)
5453           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5454           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5455         else if (difi.lt.-drange(i)) then
5456           difi=difi+drange(i)
5457           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5458           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5459         endif
5460 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5461 C     &    i,itori,rad2deg*phii,
5462 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5463       enddo
5464 !      write (iout,*) 'edihcnstr',edihcnstr
5465       return
5466       end
5467 c------------------------------------------------------------------------------
5468 #else
5469       subroutine etor(etors,edihcnstr,fact)
5470       implicit real*8 (a-h,o-z)
5471       include 'DIMENSIONS'
5472       include 'DIMENSIONS.ZSCOPT'
5473       include 'COMMON.VAR'
5474       include 'COMMON.GEO'
5475       include 'COMMON.LOCAL'
5476       include 'COMMON.TORSION'
5477       include 'COMMON.INTERACT'
5478       include 'COMMON.DERIV'
5479       include 'COMMON.CHAIN'
5480       include 'COMMON.NAMES'
5481       include 'COMMON.IOUNITS'
5482       include 'COMMON.FFIELD'
5483       include 'COMMON.TORCNSTR'
5484       logical lprn
5485 C Set lprn=.true. for debugging
5486       lprn=.false.
5487 c      lprn=.true.
5488       etors=0.0D0
5489       do i=iphi_start,iphi_end
5490         if (i.le.2) cycle
5491         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5492      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5493 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5494 C     &       .or. itype(i).eq.ntyp1) cycle
5495         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5496          if (iabs(itype(i)).eq.20) then
5497          iblock=2
5498          else
5499          iblock=1
5500          endif
5501         itori=itortyp(itype(i-2))
5502         itori1=itortyp(itype(i-1))
5503         phii=phi(i)
5504         gloci=0.0D0
5505 C Regular cosine and sine terms
5506         do j=1,nterm(itori,itori1,iblock)
5507           v1ij=v1(j,itori,itori1,iblock)
5508           v2ij=v2(j,itori,itori1,iblock)
5509           cosphi=dcos(j*phii)
5510           sinphi=dsin(j*phii)
5511           etors=etors+v1ij*cosphi+v2ij*sinphi
5512           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5513         enddo
5514 C Lorentz terms
5515 C                         v1
5516 C  E = SUM ----------------------------------- - v1
5517 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5518 C
5519         cosphi=dcos(0.5d0*phii)
5520         sinphi=dsin(0.5d0*phii)
5521         do j=1,nlor(itori,itori1,iblock)
5522           vl1ij=vlor1(j,itori,itori1)
5523           vl2ij=vlor2(j,itori,itori1)
5524           vl3ij=vlor3(j,itori,itori1)
5525           pom=vl2ij*cosphi+vl3ij*sinphi
5526           pom1=1.0d0/(pom*pom+1.0d0)
5527           etors=etors+vl1ij*pom1
5528 c          if (energy_dec) etors_ii=etors_ii+
5529 c     &                vl1ij*pom1
5530           pom=-pom*pom1*pom1
5531           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5532         enddo
5533 C Subtract the constant term
5534         etors=etors-v0(itori,itori1,iblock)
5535         if (lprn)
5536      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5537      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5538      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5539         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5540 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5541  1215   continue
5542       enddo
5543 ! 6/20/98 - dihedral angle constraints
5544       edihcnstr=0.0d0
5545       do i=1,ndih_constr
5546         itori=idih_constr(i)
5547         phii=phi(itori)
5548         difi=pinorm(phii-phi0(i))
5549         edihi=0.0d0
5550         if (difi.gt.drange(i)) then
5551           difi=difi-drange(i)
5552           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5553           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5554           edihi=0.25d0*ftors(i)*difi**4
5555         else if (difi.lt.-drange(i)) then
5556           difi=difi+drange(i)
5557           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5558           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5559           edihi=0.25d0*ftors(i)*difi**4
5560         else
5561           difi=0.0d0
5562         endif
5563         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5564      &    i,itori,rad2deg*phii,
5565      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5566 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5567 c     &    drange(i),edihi
5568 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5569 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5570       enddo
5571 !      write (iout,*) 'edihcnstr',edihcnstr
5572       return
5573       end
5574 c----------------------------------------------------------------------------
5575       subroutine etor_d(etors_d,fact2)
5576 C 6/23/01 Compute double torsional energy
5577       implicit real*8 (a-h,o-z)
5578       include 'DIMENSIONS'
5579       include 'DIMENSIONS.ZSCOPT'
5580       include 'COMMON.VAR'
5581       include 'COMMON.GEO'
5582       include 'COMMON.LOCAL'
5583       include 'COMMON.TORSION'
5584       include 'COMMON.INTERACT'
5585       include 'COMMON.DERIV'
5586       include 'COMMON.CHAIN'
5587       include 'COMMON.NAMES'
5588       include 'COMMON.IOUNITS'
5589       include 'COMMON.FFIELD'
5590       include 'COMMON.TORCNSTR'
5591       logical lprn
5592 C Set lprn=.true. for debugging
5593       lprn=.false.
5594 c     lprn=.true.
5595       etors_d=0.0D0
5596       do i=iphi_start,iphi_end-1
5597         if (i.le.3) cycle
5598 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5599 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5600          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5601      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5602      &  (itype(i+1).eq.ntyp1)) cycle
5603         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5604      &     goto 1215
5605         itori=itortyp(itype(i-2))
5606         itori1=itortyp(itype(i-1))
5607         itori2=itortyp(itype(i))
5608         phii=phi(i)
5609         phii1=phi(i+1)
5610         gloci1=0.0D0
5611         gloci2=0.0D0
5612         iblock=1
5613         if (iabs(itype(i+1)).eq.20) iblock=2
5614 C Regular cosine and sine terms
5615         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5616           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5617           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5618           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5619           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5620           cosphi1=dcos(j*phii)
5621           sinphi1=dsin(j*phii)
5622           cosphi2=dcos(j*phii1)
5623           sinphi2=dsin(j*phii1)
5624           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5625      &     v2cij*cosphi2+v2sij*sinphi2
5626           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5627           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5628         enddo
5629         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5630           do l=1,k-1
5631             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5632             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5633             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5634             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5635             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5636             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5637             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5638             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5639             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5640      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5641             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5642      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5643             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5644      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5645           enddo
5646         enddo
5647         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5648         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5649  1215   continue
5650       enddo
5651       return
5652       end
5653 #endif
5654 c------------------------------------------------------------------------------
5655       subroutine eback_sc_corr(esccor)
5656 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5657 c        conformational states; temporarily implemented as differences
5658 c        between UNRES torsional potentials (dependent on three types of
5659 c        residues) and the torsional potentials dependent on all 20 types
5660 c        of residues computed from AM1 energy surfaces of terminally-blocked
5661 c        amino-acid residues.
5662       implicit real*8 (a-h,o-z)
5663       include 'DIMENSIONS'
5664       include 'DIMENSIONS.ZSCOPT'
5665       include 'COMMON.VAR'
5666       include 'COMMON.GEO'
5667       include 'COMMON.LOCAL'
5668       include 'COMMON.TORSION'
5669       include 'COMMON.SCCOR'
5670       include 'COMMON.INTERACT'
5671       include 'COMMON.DERIV'
5672       include 'COMMON.CHAIN'
5673       include 'COMMON.NAMES'
5674       include 'COMMON.IOUNITS'
5675       include 'COMMON.FFIELD'
5676       include 'COMMON.CONTROL'
5677       logical lprn
5678 C Set lprn=.true. for debugging
5679       lprn=.false.
5680 c      lprn=.true.
5681 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5682       esccor=0.0D0
5683       do i=itau_start,itau_end
5684         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5685         esccor_ii=0.0D0
5686         isccori=isccortyp(itype(i-2))
5687         isccori1=isccortyp(itype(i-1))
5688         phii=phi(i)
5689         do intertyp=1,3 !intertyp
5690 cc Added 09 May 2012 (Adasko)
5691 cc  Intertyp means interaction type of backbone mainchain correlation:
5692 c   1 = SC...Ca...Ca...Ca
5693 c   2 = Ca...Ca...Ca...SC
5694 c   3 = SC...Ca...Ca...SCi
5695         gloci=0.0D0
5696         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5697      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5698      &      (itype(i-1).eq.ntyp1)))
5699      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5700      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5701      &     .or.(itype(i).eq.ntyp1)))
5702      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5703      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5704      &      (itype(i-3).eq.ntyp1)))) cycle
5705         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5706         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5707      & cycle
5708        do j=1,nterm_sccor(isccori,isccori1)
5709           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5710           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5711           cosphi=dcos(j*tauangle(intertyp,i))
5712           sinphi=dsin(j*tauangle(intertyp,i))
5713            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5714            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5715          enddo
5716 C      write (iout,*)"EBACK_SC_COR",esccor,i
5717 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5718 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5719 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5720         if (lprn)
5721      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5722      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5723      &  (v1sccor(j,1,itori,itori1),j=1,6)
5724      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5725 c        gsccor_loc(i-3)=gloci
5726        enddo !intertyp
5727       enddo
5728       return
5729       end
5730 c------------------------------------------------------------------------------
5731       subroutine multibody(ecorr)
5732 C This subroutine calculates multi-body contributions to energy following
5733 C the idea of Skolnick et al. If side chains I and J make a contact and
5734 C at the same time side chains I+1 and J+1 make a contact, an extra
5735 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5736       implicit real*8 (a-h,o-z)
5737       include 'DIMENSIONS'
5738       include 'COMMON.IOUNITS'
5739       include 'COMMON.DERIV'
5740       include 'COMMON.INTERACT'
5741       include 'COMMON.CONTACTS'
5742       double precision gx(3),gx1(3)
5743       logical lprn
5744
5745 C Set lprn=.true. for debugging
5746       lprn=.false.
5747
5748       if (lprn) then
5749         write (iout,'(a)') 'Contact function values:'
5750         do i=nnt,nct-2
5751           write (iout,'(i2,20(1x,i2,f10.5))')
5752      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5753         enddo
5754       endif
5755       ecorr=0.0D0
5756       do i=nnt,nct
5757         do j=1,3
5758           gradcorr(j,i)=0.0D0
5759           gradxorr(j,i)=0.0D0
5760         enddo
5761       enddo
5762       do i=nnt,nct-2
5763
5764         DO ISHIFT = 3,4
5765
5766         i1=i+ishift
5767         num_conti=num_cont(i)
5768         num_conti1=num_cont(i1)
5769         do jj=1,num_conti
5770           j=jcont(jj,i)
5771           do kk=1,num_conti1
5772             j1=jcont(kk,i1)
5773             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5774 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5775 cd   &                   ' ishift=',ishift
5776 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5777 C The system gains extra energy.
5778               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5779             endif   ! j1==j+-ishift
5780           enddo     ! kk
5781         enddo       ! jj
5782
5783         ENDDO ! ISHIFT
5784
5785       enddo         ! i
5786       return
5787       end
5788 c------------------------------------------------------------------------------
5789       double precision function esccorr(i,j,k,l,jj,kk)
5790       implicit real*8 (a-h,o-z)
5791       include 'DIMENSIONS'
5792       include 'COMMON.IOUNITS'
5793       include 'COMMON.DERIV'
5794       include 'COMMON.INTERACT'
5795       include 'COMMON.CONTACTS'
5796       double precision gx(3),gx1(3)
5797       logical lprn
5798       lprn=.false.
5799       eij=facont(jj,i)
5800       ekl=facont(kk,k)
5801 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5802 C Calculate the multi-body contribution to energy.
5803 C Calculate multi-body contributions to the gradient.
5804 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5805 cd   & k,l,(gacont(m,kk,k),m=1,3)
5806       do m=1,3
5807         gx(m) =ekl*gacont(m,jj,i)
5808         gx1(m)=eij*gacont(m,kk,k)
5809         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5810         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5811         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5812         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5813       enddo
5814       do m=i,j-1
5815         do ll=1,3
5816           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5817         enddo
5818       enddo
5819       do m=k,l-1
5820         do ll=1,3
5821           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5822         enddo
5823       enddo
5824       esccorr=-eij*ekl
5825       return
5826       end
5827 c------------------------------------------------------------------------------
5828 #ifdef MPL
5829       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5830       implicit real*8 (a-h,o-z)
5831       include 'DIMENSIONS'
5832       integer dimen1,dimen2,atom,indx
5833       double precision buffer(dimen1,dimen2)
5834       double precision zapas
5835       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5836      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5837      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5838       num_kont=num_cont_hb(atom)
5839       do i=1,num_kont
5840         do k=1,7
5841           do j=1,3
5842             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5843           enddo ! j
5844         enddo ! k
5845         buffer(i,indx+22)=facont_hb(i,atom)
5846         buffer(i,indx+23)=ees0p(i,atom)
5847         buffer(i,indx+24)=ees0m(i,atom)
5848         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5849       enddo ! i
5850       buffer(1,indx+26)=dfloat(num_kont)
5851       return
5852       end
5853 c------------------------------------------------------------------------------
5854       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5855       implicit real*8 (a-h,o-z)
5856       include 'DIMENSIONS'
5857       integer dimen1,dimen2,atom,indx
5858       double precision buffer(dimen1,dimen2)
5859       double precision zapas
5860       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5861      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5862      &         ees0m(ntyp,maxres),
5863      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5864       num_kont=buffer(1,indx+26)
5865       num_kont_old=num_cont_hb(atom)
5866       num_cont_hb(atom)=num_kont+num_kont_old
5867       do i=1,num_kont
5868         ii=i+num_kont_old
5869         do k=1,7
5870           do j=1,3
5871             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5872           enddo ! j
5873         enddo ! k
5874         facont_hb(ii,atom)=buffer(i,indx+22)
5875         ees0p(ii,atom)=buffer(i,indx+23)
5876         ees0m(ii,atom)=buffer(i,indx+24)
5877         jcont_hb(ii,atom)=buffer(i,indx+25)
5878       enddo ! i
5879       return
5880       end
5881 c------------------------------------------------------------------------------
5882 #endif
5883       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5884 C This subroutine calculates multi-body contributions to hydrogen-bonding
5885       implicit real*8 (a-h,o-z)
5886       include 'DIMENSIONS'
5887       include 'DIMENSIONS.ZSCOPT'
5888       include 'COMMON.IOUNITS'
5889 #ifdef MPL
5890       include 'COMMON.INFO'
5891 #endif
5892       include 'COMMON.FFIELD'
5893       include 'COMMON.DERIV'
5894       include 'COMMON.INTERACT'
5895       include 'COMMON.CONTACTS'
5896 #ifdef MPL
5897       parameter (max_cont=maxconts)
5898       parameter (max_dim=2*(8*3+2))
5899       parameter (msglen1=max_cont*max_dim*4)
5900       parameter (msglen2=2*msglen1)
5901       integer source,CorrelType,CorrelID,Error
5902       double precision buffer(max_cont,max_dim)
5903 #endif
5904       double precision gx(3),gx1(3)
5905       logical lprn,ldone
5906
5907 C Set lprn=.true. for debugging
5908       lprn=.false.
5909 #ifdef MPL
5910       n_corr=0
5911       n_corr1=0
5912       if (fgProcs.le.1) goto 30
5913       if (lprn) then
5914         write (iout,'(a)') 'Contact function values:'
5915         do i=nnt,nct-2
5916           write (iout,'(2i3,50(1x,i2,f5.2))')
5917      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5918      &    j=1,num_cont_hb(i))
5919         enddo
5920       endif
5921 C Caution! Following code assumes that electrostatic interactions concerning
5922 C a given atom are split among at most two processors!
5923       CorrelType=477
5924       CorrelID=MyID+1
5925       ldone=.false.
5926       do i=1,max_cont
5927         do j=1,max_dim
5928           buffer(i,j)=0.0D0
5929         enddo
5930       enddo
5931       mm=mod(MyRank,2)
5932 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5933       if (mm) 20,20,10
5934    10 continue
5935 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5936       if (MyRank.gt.0) then
5937 C Send correlation contributions to the preceding processor
5938         msglen=msglen1
5939         nn=num_cont_hb(iatel_s)
5940         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5941 cd      write (iout,*) 'The BUFFER array:'
5942 cd      do i=1,nn
5943 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5944 cd      enddo
5945         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5946           msglen=msglen2
5947             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5948 C Clear the contacts of the atom passed to the neighboring processor
5949         nn=num_cont_hb(iatel_s+1)
5950 cd      do i=1,nn
5951 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5952 cd      enddo
5953             num_cont_hb(iatel_s)=0
5954         endif
5955 cd      write (iout,*) 'Processor ',MyID,MyRank,
5956 cd   & ' is sending correlation contribution to processor',MyID-1,
5957 cd   & ' msglen=',msglen
5958 cd      write (*,*) 'Processor ',MyID,MyRank,
5959 cd   & ' is sending correlation contribution to processor',MyID-1,
5960 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5961         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5962 cd      write (iout,*) 'Processor ',MyID,
5963 cd   & ' has sent correlation contribution to processor',MyID-1,
5964 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5965 cd      write (*,*) 'Processor ',MyID,
5966 cd   & ' has sent correlation contribution to processor',MyID-1,
5967 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5968         msglen=msglen1
5969       endif ! (MyRank.gt.0)
5970       if (ldone) goto 30
5971       ldone=.true.
5972    20 continue
5973 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5974       if (MyRank.lt.fgProcs-1) then
5975 C Receive correlation contributions from the next processor
5976         msglen=msglen1
5977         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5978 cd      write (iout,*) 'Processor',MyID,
5979 cd   & ' is receiving correlation contribution from processor',MyID+1,
5980 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5981 cd      write (*,*) 'Processor',MyID,
5982 cd   & ' is receiving correlation contribution from processor',MyID+1,
5983 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5984         nbytes=-1
5985         do while (nbytes.le.0)
5986           call mp_probe(MyID+1,CorrelType,nbytes)
5987         enddo
5988 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5989         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5990 cd      write (iout,*) 'Processor',MyID,
5991 cd   & ' has received correlation contribution from processor',MyID+1,
5992 cd   & ' msglen=',msglen,' nbytes=',nbytes
5993 cd      write (iout,*) 'The received BUFFER array:'
5994 cd      do i=1,max_cont
5995 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5996 cd      enddo
5997         if (msglen.eq.msglen1) then
5998           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5999         else if (msglen.eq.msglen2)  then
6000           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6001           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6002         else
6003           write (iout,*)
6004      & 'ERROR!!!! message length changed while processing correlations.'
6005           write (*,*)
6006      & 'ERROR!!!! message length changed while processing correlations.'
6007           call mp_stopall(Error)
6008         endif ! msglen.eq.msglen1
6009       endif ! MyRank.lt.fgProcs-1
6010       if (ldone) goto 30
6011       ldone=.true.
6012       goto 10
6013    30 continue
6014 #endif
6015       if (lprn) then
6016         write (iout,'(a)') 'Contact function values:'
6017         do i=nnt,nct-2
6018           write (iout,'(2i3,50(1x,i2,f5.2))')
6019      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6020      &    j=1,num_cont_hb(i))
6021         enddo
6022       endif
6023       ecorr=0.0D0
6024 C Remove the loop below after debugging !!!
6025       do i=nnt,nct
6026         do j=1,3
6027           gradcorr(j,i)=0.0D0
6028           gradxorr(j,i)=0.0D0
6029         enddo
6030       enddo
6031 C Calculate the local-electrostatic correlation terms
6032       do i=iatel_s,iatel_e+1
6033         i1=i+1
6034         num_conti=num_cont_hb(i)
6035         num_conti1=num_cont_hb(i+1)
6036         do jj=1,num_conti
6037           j=jcont_hb(jj,i)
6038           do kk=1,num_conti1
6039             j1=jcont_hb(kk,i1)
6040 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6041 c     &         ' jj=',jj,' kk=',kk
6042             if (j1.eq.j+1 .or. j1.eq.j-1) then
6043 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6044 C The system gains extra energy.
6045               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6046               n_corr=n_corr+1
6047             else if (j1.eq.j) then
6048 C Contacts I-J and I-(J+1) occur simultaneously.
6049 C The system loses extra energy.
6050 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6051             endif
6052           enddo ! kk
6053           do kk=1,num_conti
6054             j1=jcont_hb(kk,i)
6055 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6056 c    &         ' jj=',jj,' kk=',kk
6057             if (j1.eq.j+1) then
6058 C Contacts I-J and (I+1)-J occur simultaneously.
6059 C The system loses extra energy.
6060 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6061             endif ! j1==j+1
6062           enddo ! kk
6063         enddo ! jj
6064       enddo ! i
6065       return
6066       end
6067 c------------------------------------------------------------------------------
6068       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6069      &  n_corr1)
6070 C This subroutine calculates multi-body contributions to hydrogen-bonding
6071       implicit real*8 (a-h,o-z)
6072       include 'DIMENSIONS'
6073       include 'DIMENSIONS.ZSCOPT'
6074       include 'COMMON.IOUNITS'
6075 #ifdef MPL
6076       include 'COMMON.INFO'
6077 #endif
6078       include 'COMMON.FFIELD'
6079       include 'COMMON.DERIV'
6080       include 'COMMON.INTERACT'
6081       include 'COMMON.CONTACTS'
6082 #ifdef MPL
6083       parameter (max_cont=maxconts)
6084       parameter (max_dim=2*(8*3+2))
6085       parameter (msglen1=max_cont*max_dim*4)
6086       parameter (msglen2=2*msglen1)
6087       integer source,CorrelType,CorrelID,Error
6088       double precision buffer(max_cont,max_dim)
6089 #endif
6090       double precision gx(3),gx1(3)
6091       logical lprn,ldone
6092
6093 C Set lprn=.true. for debugging
6094       lprn=.false.
6095       eturn6=0.0d0
6096       ecorr6=0.0d0
6097 #ifdef MPL
6098       n_corr=0
6099       n_corr1=0
6100       if (fgProcs.le.1) goto 30
6101       if (lprn) then
6102         write (iout,'(a)') 'Contact function values:'
6103         do i=nnt,nct-2
6104           write (iout,'(2i3,50(1x,i2,f5.2))')
6105      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6106      &    j=1,num_cont_hb(i))
6107         enddo
6108       endif
6109 C Caution! Following code assumes that electrostatic interactions concerning
6110 C a given atom are split among at most two processors!
6111       CorrelType=477
6112       CorrelID=MyID+1
6113       ldone=.false.
6114       do i=1,max_cont
6115         do j=1,max_dim
6116           buffer(i,j)=0.0D0
6117         enddo
6118       enddo
6119       mm=mod(MyRank,2)
6120 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6121       if (mm) 20,20,10
6122    10 continue
6123 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6124       if (MyRank.gt.0) then
6125 C Send correlation contributions to the preceding processor
6126         msglen=msglen1
6127         nn=num_cont_hb(iatel_s)
6128         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6129 cd      write (iout,*) 'The BUFFER array:'
6130 cd      do i=1,nn
6131 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6132 cd      enddo
6133         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6134           msglen=msglen2
6135             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6136 C Clear the contacts of the atom passed to the neighboring processor
6137         nn=num_cont_hb(iatel_s+1)
6138 cd      do i=1,nn
6139 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6140 cd      enddo
6141             num_cont_hb(iatel_s)=0
6142         endif
6143 cd      write (iout,*) 'Processor ',MyID,MyRank,
6144 cd   & ' is sending correlation contribution to processor',MyID-1,
6145 cd   & ' msglen=',msglen
6146 cd      write (*,*) 'Processor ',MyID,MyRank,
6147 cd   & ' is sending correlation contribution to processor',MyID-1,
6148 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6149         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6150 cd      write (iout,*) 'Processor ',MyID,
6151 cd   & ' has sent correlation contribution to processor',MyID-1,
6152 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6153 cd      write (*,*) 'Processor ',MyID,
6154 cd   & ' has sent correlation contribution to processor',MyID-1,
6155 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6156         msglen=msglen1
6157       endif ! (MyRank.gt.0)
6158       if (ldone) goto 30
6159       ldone=.true.
6160    20 continue
6161 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6162       if (MyRank.lt.fgProcs-1) then
6163 C Receive correlation contributions from the next processor
6164         msglen=msglen1
6165         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6166 cd      write (iout,*) 'Processor',MyID,
6167 cd   & ' is receiving correlation contribution from processor',MyID+1,
6168 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6169 cd      write (*,*) 'Processor',MyID,
6170 cd   & ' is receiving correlation contribution from processor',MyID+1,
6171 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6172         nbytes=-1
6173         do while (nbytes.le.0)
6174           call mp_probe(MyID+1,CorrelType,nbytes)
6175         enddo
6176 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6177         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6178 cd      write (iout,*) 'Processor',MyID,
6179 cd   & ' has received correlation contribution from processor',MyID+1,
6180 cd   & ' msglen=',msglen,' nbytes=',nbytes
6181 cd      write (iout,*) 'The received BUFFER array:'
6182 cd      do i=1,max_cont
6183 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6184 cd      enddo
6185         if (msglen.eq.msglen1) then
6186           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6187         else if (msglen.eq.msglen2)  then
6188           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6189           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6190         else
6191           write (iout,*)
6192      & 'ERROR!!!! message length changed while processing correlations.'
6193           write (*,*)
6194      & 'ERROR!!!! message length changed while processing correlations.'
6195           call mp_stopall(Error)
6196         endif ! msglen.eq.msglen1
6197       endif ! MyRank.lt.fgProcs-1
6198       if (ldone) goto 30
6199       ldone=.true.
6200       goto 10
6201    30 continue
6202 #endif
6203       if (lprn) then
6204         write (iout,'(a)') 'Contact function values:'
6205         do i=nnt,nct-2
6206           write (iout,'(2i3,50(1x,i2,f5.2))')
6207      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6208      &    j=1,num_cont_hb(i))
6209         enddo
6210       endif
6211       ecorr=0.0D0
6212       ecorr5=0.0d0
6213       ecorr6=0.0d0
6214 C Remove the loop below after debugging !!!
6215       do i=nnt,nct
6216         do j=1,3
6217           gradcorr(j,i)=0.0D0
6218           gradxorr(j,i)=0.0D0
6219         enddo
6220       enddo
6221 C Calculate the dipole-dipole interaction energies
6222       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6223       do i=iatel_s,iatel_e+1
6224         num_conti=num_cont_hb(i)
6225         do jj=1,num_conti
6226           j=jcont_hb(jj,i)
6227           call dipole(i,j,jj)
6228         enddo
6229       enddo
6230       endif
6231 C Calculate the local-electrostatic correlation terms
6232       do i=iatel_s,iatel_e+1
6233         i1=i+1
6234         num_conti=num_cont_hb(i)
6235         num_conti1=num_cont_hb(i+1)
6236         do jj=1,num_conti
6237           j=jcont_hb(jj,i)
6238           do kk=1,num_conti1
6239             j1=jcont_hb(kk,i1)
6240 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6241 c     &         ' jj=',jj,' kk=',kk
6242             if (j1.eq.j+1 .or. j1.eq.j-1) then
6243 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6244 C The system gains extra energy.
6245               n_corr=n_corr+1
6246               sqd1=dsqrt(d_cont(jj,i))
6247               sqd2=dsqrt(d_cont(kk,i1))
6248               sred_geom = sqd1*sqd2
6249               IF (sred_geom.lt.cutoff_corr) THEN
6250                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6251      &            ekont,fprimcont)
6252 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6253 c     &         ' jj=',jj,' kk=',kk
6254                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6255                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6256                 do l=1,3
6257                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6258                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6259                 enddo
6260                 n_corr1=n_corr1+1
6261 cd               write (iout,*) 'sred_geom=',sred_geom,
6262 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6263                 call calc_eello(i,j,i+1,j1,jj,kk)
6264                 if (wcorr4.gt.0.0d0)
6265      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6266                 if (wcorr5.gt.0.0d0)
6267      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6268 c                print *,"wcorr5",ecorr5
6269 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6270 cd                write(2,*)'ijkl',i,j,i+1,j1
6271                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6272      &               .or. wturn6.eq.0.0d0))then
6273 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6274                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6275 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6276 cd     &            'ecorr6=',ecorr6
6277 cd                write (iout,'(4e15.5)') sred_geom,
6278 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6279 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6280 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6281                 else if (wturn6.gt.0.0d0
6282      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6283 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6284                   eturn6=eturn6+eello_turn6(i,jj,kk)
6285 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6286                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6287                    eturn6=0.0d0
6288                    ecorr6=0.0d0
6289                 endif
6290
6291               ENDIF
6292 1111          continue
6293             else if (j1.eq.j) then
6294 C Contacts I-J and I-(J+1) occur simultaneously.
6295 C The system loses extra energy.
6296 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6297             endif
6298           enddo ! kk
6299           do kk=1,num_conti
6300             j1=jcont_hb(kk,i)
6301 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6302 c    &         ' jj=',jj,' kk=',kk
6303             if (j1.eq.j+1) then
6304 C Contacts I-J and (I+1)-J occur simultaneously.
6305 C The system loses extra energy.
6306 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6307             endif ! j1==j+1
6308           enddo ! kk
6309         enddo ! jj
6310       enddo ! i
6311       write (iout,*) "eturn6",eturn6,ecorr6
6312       return
6313       end
6314 c------------------------------------------------------------------------------
6315       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6316       implicit real*8 (a-h,o-z)
6317       include 'DIMENSIONS'
6318       include 'COMMON.IOUNITS'
6319       include 'COMMON.DERIV'
6320       include 'COMMON.INTERACT'
6321       include 'COMMON.CONTACTS'
6322       include 'COMMON.CONTROL'
6323       include 'COMMON.SHIELD'
6324       double precision gx(3),gx1(3)
6325       logical lprn
6326       lprn=.false.
6327       eij=facont_hb(jj,i)
6328       ekl=facont_hb(kk,k)
6329       ees0pij=ees0p(jj,i)
6330       ees0pkl=ees0p(kk,k)
6331       ees0mij=ees0m(jj,i)
6332       ees0mkl=ees0m(kk,k)
6333       ekont=eij*ekl
6334       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6335 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6336 C Following 4 lines for diagnostics.
6337 cd    ees0pkl=0.0D0
6338 cd    ees0pij=1.0D0
6339 cd    ees0mkl=0.0D0
6340 cd    ees0mij=1.0D0
6341 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6342 c    &   ' and',k,l
6343 c     write (iout,*)'Contacts have occurred for peptide groups',
6344 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6345 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6346 C Calculate the multi-body contribution to energy.
6347 C      ecorr=ecorr+ekont*ees
6348       if (calc_grad) then
6349 C Calculate multi-body contributions to the gradient.
6350       do ll=1,3
6351         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6352         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6353      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6354      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6355         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6356      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6357      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6358         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6359         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6360      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6361      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6362         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6363      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6364      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6365       enddo
6366       do m=i+1,j-1
6367         do ll=1,3
6368           gradcorr(ll,m)=gradcorr(ll,m)+
6369      &     ees*ekl*gacont_hbr(ll,jj,i)-
6370      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6371      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6372         enddo
6373       enddo
6374       do m=k+1,l-1
6375         do ll=1,3
6376           gradcorr(ll,m)=gradcorr(ll,m)+
6377      &     ees*eij*gacont_hbr(ll,kk,k)-
6378      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6379      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6380         enddo
6381       enddo
6382       if (shield_mode.gt.0) then
6383        j=ees0plist(jj,i)
6384        l=ees0plist(kk,k)
6385 C        print *,i,j,fac_shield(i),fac_shield(j),
6386 C     &fac_shield(k),fac_shield(l)
6387         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6388      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6389           do ilist=1,ishield_list(i)
6390            iresshield=shield_list(ilist,i)
6391            do m=1,3
6392            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6393 C     &      *2.0
6394            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6395      &              rlocshield
6396      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6397             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6398      &+rlocshield
6399            enddo
6400           enddo
6401           do ilist=1,ishield_list(j)
6402            iresshield=shield_list(ilist,j)
6403            do m=1,3
6404            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6405 C     &     *2.0
6406            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6407      &              rlocshield
6408      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6409            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6410      &     +rlocshield
6411            enddo
6412           enddo
6413           do ilist=1,ishield_list(k)
6414            iresshield=shield_list(ilist,k)
6415            do m=1,3
6416            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6417 C     &     *2.0
6418            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6419      &              rlocshield
6420      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6421            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6422      &     +rlocshield
6423            enddo
6424           enddo
6425           do ilist=1,ishield_list(l)
6426            iresshield=shield_list(ilist,l)
6427            do m=1,3
6428            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6429 C     &     *2.0
6430            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6431      &              rlocshield
6432      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6433            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6434      &     +rlocshield
6435            enddo
6436           enddo
6437 C          print *,gshieldx(m,iresshield)
6438           do m=1,3
6439             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6440      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6441             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6442      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6443             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6444      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6445             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6446      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6447
6448             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6449      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6450             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6451      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6452             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6453      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6454             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6455      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6456
6457            enddo
6458       endif
6459       endif
6460       endif
6461       ehbcorr=ekont*ees
6462       return
6463       end
6464 C---------------------------------------------------------------------------
6465       subroutine dipole(i,j,jj)
6466       implicit real*8 (a-h,o-z)
6467       include 'DIMENSIONS'
6468       include 'DIMENSIONS.ZSCOPT'
6469       include 'COMMON.IOUNITS'
6470       include 'COMMON.CHAIN'
6471       include 'COMMON.FFIELD'
6472       include 'COMMON.DERIV'
6473       include 'COMMON.INTERACT'
6474       include 'COMMON.CONTACTS'
6475       include 'COMMON.TORSION'
6476       include 'COMMON.VAR'
6477       include 'COMMON.GEO'
6478       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6479      &  auxmat(2,2)
6480       iti1 = itortyp(itype(i+1))
6481       if (j.lt.nres-1) then
6482         if (itype(j).le.ntyp) then
6483           itj1 = itortyp(itype(j+1))
6484         else
6485           itj=ntortyp+1
6486         endif
6487       else
6488         itj1=ntortyp+1
6489       endif
6490       do iii=1,2
6491         dipi(iii,1)=Ub2(iii,i)
6492         dipderi(iii)=Ub2der(iii,i)
6493         dipi(iii,2)=b1(iii,iti1)
6494         dipj(iii,1)=Ub2(iii,j)
6495         dipderj(iii)=Ub2der(iii,j)
6496         dipj(iii,2)=b1(iii,itj1)
6497       enddo
6498       kkk=0
6499       do iii=1,2
6500         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6501         do jjj=1,2
6502           kkk=kkk+1
6503           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6504         enddo
6505       enddo
6506       if (.not.calc_grad) return
6507       do kkk=1,5
6508         do lll=1,3
6509           mmm=0
6510           do iii=1,2
6511             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6512      &        auxvec(1))
6513             do jjj=1,2
6514               mmm=mmm+1
6515               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6516             enddo
6517           enddo
6518         enddo
6519       enddo
6520       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6521       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6522       do iii=1,2
6523         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6524       enddo
6525       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6526       do iii=1,2
6527         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6528       enddo
6529       return
6530       end
6531 C---------------------------------------------------------------------------
6532       subroutine calc_eello(i,j,k,l,jj,kk)
6533 C
6534 C This subroutine computes matrices and vectors needed to calculate
6535 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6536 C
6537       implicit real*8 (a-h,o-z)
6538       include 'DIMENSIONS'
6539       include 'DIMENSIONS.ZSCOPT'
6540       include 'COMMON.IOUNITS'
6541       include 'COMMON.CHAIN'
6542       include 'COMMON.DERIV'
6543       include 'COMMON.INTERACT'
6544       include 'COMMON.CONTACTS'
6545       include 'COMMON.TORSION'
6546       include 'COMMON.VAR'
6547       include 'COMMON.GEO'
6548       include 'COMMON.FFIELD'
6549       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6550      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6551       logical lprn
6552       common /kutas/ lprn
6553 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6554 cd     & ' jj=',jj,' kk=',kk
6555 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6556       do iii=1,2
6557         do jjj=1,2
6558           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6559           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6560         enddo
6561       enddo
6562       call transpose2(aa1(1,1),aa1t(1,1))
6563       call transpose2(aa2(1,1),aa2t(1,1))
6564       do kkk=1,5
6565         do lll=1,3
6566           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6567      &      aa1tder(1,1,lll,kkk))
6568           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6569      &      aa2tder(1,1,lll,kkk))
6570         enddo
6571       enddo
6572       if (l.eq.j+1) then
6573 C parallel orientation of the two CA-CA-CA frames.
6574         if (i.gt.1 .and. itype(i).le.ntyp) then
6575           iti=itortyp(itype(i))
6576         else
6577           iti=ntortyp+1
6578         endif
6579         itk1=itortyp(itype(k+1))
6580         itj=itortyp(itype(j))
6581         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6582           itl1=itortyp(itype(l+1))
6583         else
6584           itl1=ntortyp+1
6585         endif
6586 C A1 kernel(j+1) A2T
6587 cd        do iii=1,2
6588 cd          write (iout,'(3f10.5,5x,3f10.5)')
6589 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6590 cd        enddo
6591         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6592      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6593      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6594 C Following matrices are needed only for 6-th order cumulants
6595         IF (wcorr6.gt.0.0d0) THEN
6596         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6597      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6598      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6599         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6600      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6601      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6602      &   ADtEAderx(1,1,1,1,1,1))
6603         lprn=.false.
6604         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6605      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6606      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6607      &   ADtEA1derx(1,1,1,1,1,1))
6608         ENDIF
6609 C End 6-th order cumulants
6610 cd        lprn=.false.
6611 cd        if (lprn) then
6612 cd        write (2,*) 'In calc_eello6'
6613 cd        do iii=1,2
6614 cd          write (2,*) 'iii=',iii
6615 cd          do kkk=1,5
6616 cd            write (2,*) 'kkk=',kkk
6617 cd            do jjj=1,2
6618 cd              write (2,'(3(2f10.5),5x)')
6619 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6620 cd            enddo
6621 cd          enddo
6622 cd        enddo
6623 cd        endif
6624         call transpose2(EUgder(1,1,k),auxmat(1,1))
6625         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6626         call transpose2(EUg(1,1,k),auxmat(1,1))
6627         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6628         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6629         do iii=1,2
6630           do kkk=1,5
6631             do lll=1,3
6632               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6633      &          EAEAderx(1,1,lll,kkk,iii,1))
6634             enddo
6635           enddo
6636         enddo
6637 C A1T kernel(i+1) A2
6638         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6639      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6640      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6641 C Following matrices are needed only for 6-th order cumulants
6642         IF (wcorr6.gt.0.0d0) THEN
6643         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6644      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6645      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6646         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6647      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6648      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6649      &   ADtEAderx(1,1,1,1,1,2))
6650         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6651      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6652      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6653      &   ADtEA1derx(1,1,1,1,1,2))
6654         ENDIF
6655 C End 6-th order cumulants
6656         call transpose2(EUgder(1,1,l),auxmat(1,1))
6657         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6658         call transpose2(EUg(1,1,l),auxmat(1,1))
6659         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6660         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6661         do iii=1,2
6662           do kkk=1,5
6663             do lll=1,3
6664               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6665      &          EAEAderx(1,1,lll,kkk,iii,2))
6666             enddo
6667           enddo
6668         enddo
6669 C AEAb1 and AEAb2
6670 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6671 C They are needed only when the fifth- or the sixth-order cumulants are
6672 C indluded.
6673         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6674         call transpose2(AEA(1,1,1),auxmat(1,1))
6675         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6676         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6677         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6678         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6679         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6680         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6681         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6682         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6683         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6684         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6685         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6686         call transpose2(AEA(1,1,2),auxmat(1,1))
6687         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6688         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6689         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6690         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6691         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6692         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6693         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6694         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6695         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6696         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6697         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6698 C Calculate the Cartesian derivatives of the vectors.
6699         do iii=1,2
6700           do kkk=1,5
6701             do lll=1,3
6702               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6703               call matvec2(auxmat(1,1),b1(1,iti),
6704      &          AEAb1derx(1,lll,kkk,iii,1,1))
6705               call matvec2(auxmat(1,1),Ub2(1,i),
6706      &          AEAb2derx(1,lll,kkk,iii,1,1))
6707               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6708      &          AEAb1derx(1,lll,kkk,iii,2,1))
6709               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6710      &          AEAb2derx(1,lll,kkk,iii,2,1))
6711               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6712               call matvec2(auxmat(1,1),b1(1,itj),
6713      &          AEAb1derx(1,lll,kkk,iii,1,2))
6714               call matvec2(auxmat(1,1),Ub2(1,j),
6715      &          AEAb2derx(1,lll,kkk,iii,1,2))
6716               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6717      &          AEAb1derx(1,lll,kkk,iii,2,2))
6718               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6719      &          AEAb2derx(1,lll,kkk,iii,2,2))
6720             enddo
6721           enddo
6722         enddo
6723         ENDIF
6724 C End vectors
6725       else
6726 C Antiparallel orientation of the two CA-CA-CA frames.
6727         if (i.gt.1 .and. itype(i).le.ntyp) then
6728           iti=itortyp(itype(i))
6729         else
6730           iti=ntortyp+1
6731         endif
6732         itk1=itortyp(itype(k+1))
6733         itl=itortyp(itype(l))
6734         itj=itortyp(itype(j))
6735         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6736           itj1=itortyp(itype(j+1))
6737         else
6738           itj1=ntortyp+1
6739         endif
6740 C A2 kernel(j-1)T A1T
6741         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6742      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6743      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6744 C Following matrices are needed only for 6-th order cumulants
6745         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6746      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6747         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6748      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6749      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6750         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6751      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6752      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6753      &   ADtEAderx(1,1,1,1,1,1))
6754         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6755      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6756      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6757      &   ADtEA1derx(1,1,1,1,1,1))
6758         ENDIF
6759 C End 6-th order cumulants
6760         call transpose2(EUgder(1,1,k),auxmat(1,1))
6761         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6762         call transpose2(EUg(1,1,k),auxmat(1,1))
6763         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6764         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6765         do iii=1,2
6766           do kkk=1,5
6767             do lll=1,3
6768               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6769      &          EAEAderx(1,1,lll,kkk,iii,1))
6770             enddo
6771           enddo
6772         enddo
6773 C A2T kernel(i+1)T A1
6774         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6775      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6776      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6777 C Following matrices are needed only for 6-th order cumulants
6778         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6779      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6780         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6781      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6782      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6783         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6784      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6785      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6786      &   ADtEAderx(1,1,1,1,1,2))
6787         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6788      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6789      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6790      &   ADtEA1derx(1,1,1,1,1,2))
6791         ENDIF
6792 C End 6-th order cumulants
6793         call transpose2(EUgder(1,1,j),auxmat(1,1))
6794         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6795         call transpose2(EUg(1,1,j),auxmat(1,1))
6796         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6797         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6798         do iii=1,2
6799           do kkk=1,5
6800             do lll=1,3
6801               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6802      &          EAEAderx(1,1,lll,kkk,iii,2))
6803             enddo
6804           enddo
6805         enddo
6806 C AEAb1 and AEAb2
6807 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6808 C They are needed only when the fifth- or the sixth-order cumulants are
6809 C indluded.
6810         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6811      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6812         call transpose2(AEA(1,1,1),auxmat(1,1))
6813         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6814         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6815         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6816         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6817         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6818         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6819         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6820         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6821         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6822         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6823         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6824         call transpose2(AEA(1,1,2),auxmat(1,1))
6825         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6826         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6827         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6828         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6829         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6830         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6831         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6832         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6833         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6834         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6835         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6836 C Calculate the Cartesian derivatives of the vectors.
6837         do iii=1,2
6838           do kkk=1,5
6839             do lll=1,3
6840               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6841               call matvec2(auxmat(1,1),b1(1,iti),
6842      &          AEAb1derx(1,lll,kkk,iii,1,1))
6843               call matvec2(auxmat(1,1),Ub2(1,i),
6844      &          AEAb2derx(1,lll,kkk,iii,1,1))
6845               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6846      &          AEAb1derx(1,lll,kkk,iii,2,1))
6847               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6848      &          AEAb2derx(1,lll,kkk,iii,2,1))
6849               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6850               call matvec2(auxmat(1,1),b1(1,itl),
6851      &          AEAb1derx(1,lll,kkk,iii,1,2))
6852               call matvec2(auxmat(1,1),Ub2(1,l),
6853      &          AEAb2derx(1,lll,kkk,iii,1,2))
6854               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6855      &          AEAb1derx(1,lll,kkk,iii,2,2))
6856               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6857      &          AEAb2derx(1,lll,kkk,iii,2,2))
6858             enddo
6859           enddo
6860         enddo
6861         ENDIF
6862 C End vectors
6863       endif
6864       return
6865       end
6866 C---------------------------------------------------------------------------
6867       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6868      &  KK,KKderg,AKA,AKAderg,AKAderx)
6869       implicit none
6870       integer nderg
6871       logical transp
6872       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6873      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6874      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6875       integer iii,kkk,lll
6876       integer jjj,mmm
6877       logical lprn
6878       common /kutas/ lprn
6879       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6880       do iii=1,nderg
6881         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6882      &    AKAderg(1,1,iii))
6883       enddo
6884 cd      if (lprn) write (2,*) 'In kernel'
6885       do kkk=1,5
6886 cd        if (lprn) write (2,*) 'kkk=',kkk
6887         do lll=1,3
6888           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6889      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6890 cd          if (lprn) then
6891 cd            write (2,*) 'lll=',lll
6892 cd            write (2,*) 'iii=1'
6893 cd            do jjj=1,2
6894 cd              write (2,'(3(2f10.5),5x)')
6895 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6896 cd            enddo
6897 cd          endif
6898           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6899      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6900 cd          if (lprn) then
6901 cd            write (2,*) 'lll=',lll
6902 cd            write (2,*) 'iii=2'
6903 cd            do jjj=1,2
6904 cd              write (2,'(3(2f10.5),5x)')
6905 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6906 cd            enddo
6907 cd          endif
6908         enddo
6909       enddo
6910       return
6911       end
6912 C---------------------------------------------------------------------------
6913       double precision function eello4(i,j,k,l,jj,kk)
6914       implicit real*8 (a-h,o-z)
6915       include 'DIMENSIONS'
6916       include 'DIMENSIONS.ZSCOPT'
6917       include 'COMMON.IOUNITS'
6918       include 'COMMON.CHAIN'
6919       include 'COMMON.DERIV'
6920       include 'COMMON.INTERACT'
6921       include 'COMMON.CONTACTS'
6922       include 'COMMON.TORSION'
6923       include 'COMMON.VAR'
6924       include 'COMMON.GEO'
6925       double precision pizda(2,2),ggg1(3),ggg2(3)
6926 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6927 cd        eello4=0.0d0
6928 cd        return
6929 cd      endif
6930 cd      print *,'eello4:',i,j,k,l,jj,kk
6931 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6932 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6933 cold      eij=facont_hb(jj,i)
6934 cold      ekl=facont_hb(kk,k)
6935 cold      ekont=eij*ekl
6936       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6937       if (calc_grad) then
6938 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6939       gcorr_loc(k-1)=gcorr_loc(k-1)
6940      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6941       if (l.eq.j+1) then
6942         gcorr_loc(l-1)=gcorr_loc(l-1)
6943      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6944       else
6945         gcorr_loc(j-1)=gcorr_loc(j-1)
6946      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6947       endif
6948       do iii=1,2
6949         do kkk=1,5
6950           do lll=1,3
6951             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6952      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6953 cd            derx(lll,kkk,iii)=0.0d0
6954           enddo
6955         enddo
6956       enddo
6957 cd      gcorr_loc(l-1)=0.0d0
6958 cd      gcorr_loc(j-1)=0.0d0
6959 cd      gcorr_loc(k-1)=0.0d0
6960 cd      eel4=1.0d0
6961 cd      write (iout,*)'Contacts have occurred for peptide groups',
6962 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6963 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6964       if (j.lt.nres-1) then
6965         j1=j+1
6966         j2=j-1
6967       else
6968         j1=j-1
6969         j2=j-2
6970       endif
6971       if (l.lt.nres-1) then
6972         l1=l+1
6973         l2=l-1
6974       else
6975         l1=l-1
6976         l2=l-2
6977       endif
6978       do ll=1,3
6979 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6980         ggg1(ll)=eel4*g_contij(ll,1)
6981         ggg2(ll)=eel4*g_contij(ll,2)
6982         ghalf=0.5d0*ggg1(ll)
6983 cd        ghalf=0.0d0
6984         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6985         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6986         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6987         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6988 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6989         ghalf=0.5d0*ggg2(ll)
6990 cd        ghalf=0.0d0
6991         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6992         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6993         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6994         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6995       enddo
6996 cd      goto 1112
6997       do m=i+1,j-1
6998         do ll=1,3
6999 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7000           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7001         enddo
7002       enddo
7003       do m=k+1,l-1
7004         do ll=1,3
7005 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7006           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7007         enddo
7008       enddo
7009 1112  continue
7010       do m=i+2,j2
7011         do ll=1,3
7012           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7013         enddo
7014       enddo
7015       do m=k+2,l2
7016         do ll=1,3
7017           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7018         enddo
7019       enddo
7020 cd      do iii=1,nres-3
7021 cd        write (2,*) iii,gcorr_loc(iii)
7022 cd      enddo
7023       endif
7024       eello4=ekont*eel4
7025 cd      write (2,*) 'ekont',ekont
7026 cd      write (iout,*) 'eello4',ekont*eel4
7027       return
7028       end
7029 C---------------------------------------------------------------------------
7030       double precision function eello5(i,j,k,l,jj,kk)
7031       implicit real*8 (a-h,o-z)
7032       include 'DIMENSIONS'
7033       include 'DIMENSIONS.ZSCOPT'
7034       include 'COMMON.IOUNITS'
7035       include 'COMMON.CHAIN'
7036       include 'COMMON.DERIV'
7037       include 'COMMON.INTERACT'
7038       include 'COMMON.CONTACTS'
7039       include 'COMMON.TORSION'
7040       include 'COMMON.VAR'
7041       include 'COMMON.GEO'
7042       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7043       double precision ggg1(3),ggg2(3)
7044 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7045 C                                                                              C
7046 C                            Parallel chains                                   C
7047 C                                                                              C
7048 C          o             o                   o             o                   C
7049 C         /l\           / \             \   / \           / \   /              C
7050 C        /   \         /   \             \ /   \         /   \ /               C
7051 C       j| o |l1       | o |              o| o |         | o |o                C
7052 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7053 C      \i/   \         /   \ /             /   \         /   \                 C
7054 C       o    k1             o                                                  C
7055 C         (I)          (II)                (III)          (IV)                 C
7056 C                                                                              C
7057 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7058 C                                                                              C
7059 C                            Antiparallel chains                               C
7060 C                                                                              C
7061 C          o             o                   o             o                   C
7062 C         /j\           / \             \   / \           / \   /              C
7063 C        /   \         /   \             \ /   \         /   \ /               C
7064 C      j1| o |l        | o |              o| o |         | o |o                C
7065 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7066 C      \i/   \         /   \ /             /   \         /   \                 C
7067 C       o     k1            o                                                  C
7068 C         (I)          (II)                (III)          (IV)                 C
7069 C                                                                              C
7070 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7071 C                                                                              C
7072 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7073 C                                                                              C
7074 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7075 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7076 cd        eello5=0.0d0
7077 cd        return
7078 cd      endif
7079 cd      write (iout,*)
7080 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7081 cd     &   ' and',k,l
7082       itk=itortyp(itype(k))
7083       itl=itortyp(itype(l))
7084       itj=itortyp(itype(j))
7085       eello5_1=0.0d0
7086       eello5_2=0.0d0
7087       eello5_3=0.0d0
7088       eello5_4=0.0d0
7089 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7090 cd     &   eel5_3_num,eel5_4_num)
7091       do iii=1,2
7092         do kkk=1,5
7093           do lll=1,3
7094             derx(lll,kkk,iii)=0.0d0
7095           enddo
7096         enddo
7097       enddo
7098 cd      eij=facont_hb(jj,i)
7099 cd      ekl=facont_hb(kk,k)
7100 cd      ekont=eij*ekl
7101 cd      write (iout,*)'Contacts have occurred for peptide groups',
7102 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7103 cd      goto 1111
7104 C Contribution from the graph I.
7105 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7106 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7107       call transpose2(EUg(1,1,k),auxmat(1,1))
7108       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7109       vv(1)=pizda(1,1)-pizda(2,2)
7110       vv(2)=pizda(1,2)+pizda(2,1)
7111       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7112      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7113       if (calc_grad) then
7114 C Explicit gradient in virtual-dihedral angles.
7115       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7116      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7117      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7118       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7119       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7120       vv(1)=pizda(1,1)-pizda(2,2)
7121       vv(2)=pizda(1,2)+pizda(2,1)
7122       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7123      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7124      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7125       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7126       vv(1)=pizda(1,1)-pizda(2,2)
7127       vv(2)=pizda(1,2)+pizda(2,1)
7128       if (l.eq.j+1) then
7129         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7130      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7131      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7132       else
7133         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7134      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7135      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7136       endif
7137 C Cartesian gradient
7138       do iii=1,2
7139         do kkk=1,5
7140           do lll=1,3
7141             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7142      &        pizda(1,1))
7143             vv(1)=pizda(1,1)-pizda(2,2)
7144             vv(2)=pizda(1,2)+pizda(2,1)
7145             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7146      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7147      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7148           enddo
7149         enddo
7150       enddo
7151 c      goto 1112
7152       endif
7153 c1111  continue
7154 C Contribution from graph II
7155       call transpose2(EE(1,1,itk),auxmat(1,1))
7156       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7157       vv(1)=pizda(1,1)+pizda(2,2)
7158       vv(2)=pizda(2,1)-pizda(1,2)
7159       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7160      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7161       if (calc_grad) then
7162 C Explicit gradient in virtual-dihedral angles.
7163       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7164      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7165       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7166       vv(1)=pizda(1,1)+pizda(2,2)
7167       vv(2)=pizda(2,1)-pizda(1,2)
7168       if (l.eq.j+1) then
7169         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7170      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7171      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7172       else
7173         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7174      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7175      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7176       endif
7177 C Cartesian gradient
7178       do iii=1,2
7179         do kkk=1,5
7180           do lll=1,3
7181             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7182      &        pizda(1,1))
7183             vv(1)=pizda(1,1)+pizda(2,2)
7184             vv(2)=pizda(2,1)-pizda(1,2)
7185             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7186      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7187      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7188           enddo
7189         enddo
7190       enddo
7191 cd      goto 1112
7192       endif
7193 cd1111  continue
7194       if (l.eq.j+1) then
7195 cd        goto 1110
7196 C Parallel orientation
7197 C Contribution from graph III
7198         call transpose2(EUg(1,1,l),auxmat(1,1))
7199         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7200         vv(1)=pizda(1,1)-pizda(2,2)
7201         vv(2)=pizda(1,2)+pizda(2,1)
7202         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7203      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7204         if (calc_grad) then
7205 C Explicit gradient in virtual-dihedral angles.
7206         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7207      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7208      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7209         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7210         vv(1)=pizda(1,1)-pizda(2,2)
7211         vv(2)=pizda(1,2)+pizda(2,1)
7212         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7213      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7214      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7215         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7216         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7217         vv(1)=pizda(1,1)-pizda(2,2)
7218         vv(2)=pizda(1,2)+pizda(2,1)
7219         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7220      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7221      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7222 C Cartesian gradient
7223         do iii=1,2
7224           do kkk=1,5
7225             do lll=1,3
7226               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7227      &          pizda(1,1))
7228               vv(1)=pizda(1,1)-pizda(2,2)
7229               vv(2)=pizda(1,2)+pizda(2,1)
7230               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7231      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7232      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7233             enddo
7234           enddo
7235         enddo
7236 cd        goto 1112
7237         endif
7238 C Contribution from graph IV
7239 cd1110    continue
7240         call transpose2(EE(1,1,itl),auxmat(1,1))
7241         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7242         vv(1)=pizda(1,1)+pizda(2,2)
7243         vv(2)=pizda(2,1)-pizda(1,2)
7244         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7245      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7246         if (calc_grad) then
7247 C Explicit gradient in virtual-dihedral angles.
7248         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7249      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7250         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7251         vv(1)=pizda(1,1)+pizda(2,2)
7252         vv(2)=pizda(2,1)-pizda(1,2)
7253         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7254      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7255      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7256 C Cartesian gradient
7257         do iii=1,2
7258           do kkk=1,5
7259             do lll=1,3
7260               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7261      &          pizda(1,1))
7262               vv(1)=pizda(1,1)+pizda(2,2)
7263               vv(2)=pizda(2,1)-pizda(1,2)
7264               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7265      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7266      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7267             enddo
7268           enddo
7269         enddo
7270         endif
7271       else
7272 C Antiparallel orientation
7273 C Contribution from graph III
7274 c        goto 1110
7275         call transpose2(EUg(1,1,j),auxmat(1,1))
7276         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7277         vv(1)=pizda(1,1)-pizda(2,2)
7278         vv(2)=pizda(1,2)+pizda(2,1)
7279         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7280      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7281         if (calc_grad) then
7282 C Explicit gradient in virtual-dihedral angles.
7283         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7284      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7285      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7286         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7287         vv(1)=pizda(1,1)-pizda(2,2)
7288         vv(2)=pizda(1,2)+pizda(2,1)
7289         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7290      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7291      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7292         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7293         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7294         vv(1)=pizda(1,1)-pizda(2,2)
7295         vv(2)=pizda(1,2)+pizda(2,1)
7296         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7297      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7298      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7299 C Cartesian gradient
7300         do iii=1,2
7301           do kkk=1,5
7302             do lll=1,3
7303               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7304      &          pizda(1,1))
7305               vv(1)=pizda(1,1)-pizda(2,2)
7306               vv(2)=pizda(1,2)+pizda(2,1)
7307               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7308      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7309      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7310             enddo
7311           enddo
7312         enddo
7313 cd        goto 1112
7314         endif
7315 C Contribution from graph IV
7316 1110    continue
7317         call transpose2(EE(1,1,itj),auxmat(1,1))
7318         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7319         vv(1)=pizda(1,1)+pizda(2,2)
7320         vv(2)=pizda(2,1)-pizda(1,2)
7321         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7322      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7323         if (calc_grad) then
7324 C Explicit gradient in virtual-dihedral angles.
7325         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7326      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7327         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7328         vv(1)=pizda(1,1)+pizda(2,2)
7329         vv(2)=pizda(2,1)-pizda(1,2)
7330         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7331      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7332      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7333 C Cartesian gradient
7334         do iii=1,2
7335           do kkk=1,5
7336             do lll=1,3
7337               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7338      &          pizda(1,1))
7339               vv(1)=pizda(1,1)+pizda(2,2)
7340               vv(2)=pizda(2,1)-pizda(1,2)
7341               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7342      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7343      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7344             enddo
7345           enddo
7346         enddo
7347       endif
7348       endif
7349 1112  continue
7350       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7351 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7352 cd        write (2,*) 'ijkl',i,j,k,l
7353 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7354 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7355 cd      endif
7356 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7357 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7358 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7359 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7360       if (calc_grad) then
7361       if (j.lt.nres-1) then
7362         j1=j+1
7363         j2=j-1
7364       else
7365         j1=j-1
7366         j2=j-2
7367       endif
7368       if (l.lt.nres-1) then
7369         l1=l+1
7370         l2=l-1
7371       else
7372         l1=l-1
7373         l2=l-2
7374       endif
7375 cd      eij=1.0d0
7376 cd      ekl=1.0d0
7377 cd      ekont=1.0d0
7378 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7379       do ll=1,3
7380         ggg1(ll)=eel5*g_contij(ll,1)
7381         ggg2(ll)=eel5*g_contij(ll,2)
7382 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7383         ghalf=0.5d0*ggg1(ll)
7384 cd        ghalf=0.0d0
7385         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7386         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7387         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7388         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7389 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7390         ghalf=0.5d0*ggg2(ll)
7391 cd        ghalf=0.0d0
7392         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7393         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7394         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7395         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7396       enddo
7397 cd      goto 1112
7398       do m=i+1,j-1
7399         do ll=1,3
7400 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7401           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7402         enddo
7403       enddo
7404       do m=k+1,l-1
7405         do ll=1,3
7406 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7407           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7408         enddo
7409       enddo
7410 c1112  continue
7411       do m=i+2,j2
7412         do ll=1,3
7413           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7414         enddo
7415       enddo
7416       do m=k+2,l2
7417         do ll=1,3
7418           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7419         enddo
7420       enddo
7421 cd      do iii=1,nres-3
7422 cd        write (2,*) iii,g_corr5_loc(iii)
7423 cd      enddo
7424       endif
7425       eello5=ekont*eel5
7426 cd      write (2,*) 'ekont',ekont
7427 cd      write (iout,*) 'eello5',ekont*eel5
7428       return
7429       end
7430 c--------------------------------------------------------------------------
7431       double precision function eello6(i,j,k,l,jj,kk)
7432       implicit real*8 (a-h,o-z)
7433       include 'DIMENSIONS'
7434       include 'DIMENSIONS.ZSCOPT'
7435       include 'COMMON.IOUNITS'
7436       include 'COMMON.CHAIN'
7437       include 'COMMON.DERIV'
7438       include 'COMMON.INTERACT'
7439       include 'COMMON.CONTACTS'
7440       include 'COMMON.TORSION'
7441       include 'COMMON.VAR'
7442       include 'COMMON.GEO'
7443       include 'COMMON.FFIELD'
7444       double precision ggg1(3),ggg2(3)
7445 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7446 cd        eello6=0.0d0
7447 cd        return
7448 cd      endif
7449 cd      write (iout,*)
7450 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7451 cd     &   ' and',k,l
7452       eello6_1=0.0d0
7453       eello6_2=0.0d0
7454       eello6_3=0.0d0
7455       eello6_4=0.0d0
7456       eello6_5=0.0d0
7457       eello6_6=0.0d0
7458 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7459 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7460       do iii=1,2
7461         do kkk=1,5
7462           do lll=1,3
7463             derx(lll,kkk,iii)=0.0d0
7464           enddo
7465         enddo
7466       enddo
7467 cd      eij=facont_hb(jj,i)
7468 cd      ekl=facont_hb(kk,k)
7469 cd      ekont=eij*ekl
7470 cd      eij=1.0d0
7471 cd      ekl=1.0d0
7472 cd      ekont=1.0d0
7473       if (l.eq.j+1) then
7474         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7475         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7476         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7477         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7478         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7479         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7480       else
7481         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7482         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7483         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7484         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7485         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7486           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7487         else
7488           eello6_5=0.0d0
7489         endif
7490         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7491       endif
7492 C If turn contributions are considered, they will be handled separately.
7493       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7494 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7495 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7496 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7497 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7498 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7499 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7500 cd      goto 1112
7501       if (calc_grad) then
7502       if (j.lt.nres-1) then
7503         j1=j+1
7504         j2=j-1
7505       else
7506         j1=j-1
7507         j2=j-2
7508       endif
7509       if (l.lt.nres-1) then
7510         l1=l+1
7511         l2=l-1
7512       else
7513         l1=l-1
7514         l2=l-2
7515       endif
7516       do ll=1,3
7517         ggg1(ll)=eel6*g_contij(ll,1)
7518         ggg2(ll)=eel6*g_contij(ll,2)
7519 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7520         ghalf=0.5d0*ggg1(ll)
7521 cd        ghalf=0.0d0
7522         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7523         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7524         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7525         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7526         ghalf=0.5d0*ggg2(ll)
7527 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7528 cd        ghalf=0.0d0
7529         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7530         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7531         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7532         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7533       enddo
7534 cd      goto 1112
7535       do m=i+1,j-1
7536         do ll=1,3
7537 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7538           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7539         enddo
7540       enddo
7541       do m=k+1,l-1
7542         do ll=1,3
7543 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7544           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7545         enddo
7546       enddo
7547 1112  continue
7548       do m=i+2,j2
7549         do ll=1,3
7550           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7551         enddo
7552       enddo
7553       do m=k+2,l2
7554         do ll=1,3
7555           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7556         enddo
7557       enddo
7558 cd      do iii=1,nres-3
7559 cd        write (2,*) iii,g_corr6_loc(iii)
7560 cd      enddo
7561       endif
7562       eello6=ekont*eel6
7563 cd      write (2,*) 'ekont',ekont
7564 cd      write (iout,*) 'eello6',ekont*eel6
7565       return
7566       end
7567 c--------------------------------------------------------------------------
7568       double precision function eello6_graph1(i,j,k,l,imat,swap)
7569       implicit real*8 (a-h,o-z)
7570       include 'DIMENSIONS'
7571       include 'DIMENSIONS.ZSCOPT'
7572       include 'COMMON.IOUNITS'
7573       include 'COMMON.CHAIN'
7574       include 'COMMON.DERIV'
7575       include 'COMMON.INTERACT'
7576       include 'COMMON.CONTACTS'
7577       include 'COMMON.TORSION'
7578       include 'COMMON.VAR'
7579       include 'COMMON.GEO'
7580       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7581       logical swap
7582       logical lprn
7583       common /kutas/ lprn
7584 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7585 C                                                                              C
7586 C      Parallel       Antiparallel                                             C
7587 C                                                                              C
7588 C          o             o                                                     C
7589 C         /l\           /j\                                                    C
7590 C        /   \         /   \                                                   C
7591 C       /| o |         | o |\                                                  C
7592 C     \ j|/k\|  /   \  |/k\|l /                                                C
7593 C      \ /   \ /     \ /   \ /                                                 C
7594 C       o     o       o     o                                                  C
7595 C       i             i                                                        C
7596 C                                                                              C
7597 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7598       itk=itortyp(itype(k))
7599       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7600       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7601       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7602       call transpose2(EUgC(1,1,k),auxmat(1,1))
7603       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7604       vv1(1)=pizda1(1,1)-pizda1(2,2)
7605       vv1(2)=pizda1(1,2)+pizda1(2,1)
7606       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7607       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7608       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7609       s5=scalar2(vv(1),Dtobr2(1,i))
7610 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7611       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7612       if (.not. calc_grad) return
7613       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7614      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7615      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7616      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7617      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7618      & +scalar2(vv(1),Dtobr2der(1,i)))
7619       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7620       vv1(1)=pizda1(1,1)-pizda1(2,2)
7621       vv1(2)=pizda1(1,2)+pizda1(2,1)
7622       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7623       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7624       if (l.eq.j+1) then
7625         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7626      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7627      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7628      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7629      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7630       else
7631         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7632      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7633      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7634      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7635      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7636       endif
7637       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7638       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7639       vv1(1)=pizda1(1,1)-pizda1(2,2)
7640       vv1(2)=pizda1(1,2)+pizda1(2,1)
7641       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7642      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7643      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7644      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7645       do iii=1,2
7646         if (swap) then
7647           ind=3-iii
7648         else
7649           ind=iii
7650         endif
7651         do kkk=1,5
7652           do lll=1,3
7653             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7654             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7655             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7656             call transpose2(EUgC(1,1,k),auxmat(1,1))
7657             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7658      &        pizda1(1,1))
7659             vv1(1)=pizda1(1,1)-pizda1(2,2)
7660             vv1(2)=pizda1(1,2)+pizda1(2,1)
7661             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7662             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7663      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7664             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7665      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7666             s5=scalar2(vv(1),Dtobr2(1,i))
7667             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7668           enddo
7669         enddo
7670       enddo
7671       return
7672       end
7673 c----------------------------------------------------------------------------
7674       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7675       implicit real*8 (a-h,o-z)
7676       include 'DIMENSIONS'
7677       include 'DIMENSIONS.ZSCOPT'
7678       include 'COMMON.IOUNITS'
7679       include 'COMMON.CHAIN'
7680       include 'COMMON.DERIV'
7681       include 'COMMON.INTERACT'
7682       include 'COMMON.CONTACTS'
7683       include 'COMMON.TORSION'
7684       include 'COMMON.VAR'
7685       include 'COMMON.GEO'
7686       logical swap
7687       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7688      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7689       logical lprn
7690       common /kutas/ lprn
7691 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7692 C                                                                              C
7693 C      Parallel       Antiparallel                                             C
7694 C                                                                              C
7695 C          o             o                                                     C
7696 C     \   /l\           /j\   /                                                C
7697 C      \ /   \         /   \ /                                                 C
7698 C       o| o |         | o |o                                                  C
7699 C     \ j|/k\|      \  |/k\|l                                                  C
7700 C      \ /   \       \ /   \                                                   C
7701 C       o             o                                                        C
7702 C       i             i                                                        C
7703 C                                                                              C
7704 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7705 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7706 C AL 7/4/01 s1 would occur in the sixth-order moment,
7707 C           but not in a cluster cumulant
7708 #ifdef MOMENT
7709       s1=dip(1,jj,i)*dip(1,kk,k)
7710 #endif
7711       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7712       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7713       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7714       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7715       call transpose2(EUg(1,1,k),auxmat(1,1))
7716       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7717       vv(1)=pizda(1,1)-pizda(2,2)
7718       vv(2)=pizda(1,2)+pizda(2,1)
7719       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7720 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7721 #ifdef MOMENT
7722       eello6_graph2=-(s1+s2+s3+s4)
7723 #else
7724       eello6_graph2=-(s2+s3+s4)
7725 #endif
7726 c      eello6_graph2=-s3
7727       if (.not. calc_grad) return
7728 C Derivatives in gamma(i-1)
7729       if (i.gt.1) then
7730 #ifdef MOMENT
7731         s1=dipderg(1,jj,i)*dip(1,kk,k)
7732 #endif
7733         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7734         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7735         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7736         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7737 #ifdef MOMENT
7738         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7739 #else
7740         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7741 #endif
7742 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7743       endif
7744 C Derivatives in gamma(k-1)
7745 #ifdef MOMENT
7746       s1=dip(1,jj,i)*dipderg(1,kk,k)
7747 #endif
7748       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7749       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7750       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7751       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7752       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7753       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7754       vv(1)=pizda(1,1)-pizda(2,2)
7755       vv(2)=pizda(1,2)+pizda(2,1)
7756       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7757 #ifdef MOMENT
7758       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7759 #else
7760       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7761 #endif
7762 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7763 C Derivatives in gamma(j-1) or gamma(l-1)
7764       if (j.gt.1) then
7765 #ifdef MOMENT
7766         s1=dipderg(3,jj,i)*dip(1,kk,k)
7767 #endif
7768         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7769         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7770         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7771         call matmat2(ADtEA1derg(1,1,1,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(l-1)=g_corr6_loc(l-1)-ekont*s1
7778         else
7779           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7780         endif
7781 #endif
7782         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7783 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7784       endif
7785 C Derivatives in gamma(l-1) or gamma(j-1)
7786       if (l.gt.1) then
7787 #ifdef MOMENT
7788         s1=dip(1,jj,i)*dipderg(3,kk,k)
7789 #endif
7790         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7791         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7792         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7793         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7794         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7795         vv(1)=pizda(1,1)-pizda(2,2)
7796         vv(2)=pizda(1,2)+pizda(2,1)
7797         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7798 #ifdef MOMENT
7799         if (swap) then
7800           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7801         else
7802           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7803         endif
7804 #endif
7805         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7806 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7807       endif
7808 C Cartesian derivatives.
7809       if (lprn) then
7810         write (2,*) 'In eello6_graph2'
7811         do iii=1,2
7812           write (2,*) 'iii=',iii
7813           do kkk=1,5
7814             write (2,*) 'kkk=',kkk
7815             do jjj=1,2
7816               write (2,'(3(2f10.5),5x)')
7817      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7818             enddo
7819           enddo
7820         enddo
7821       endif
7822       do iii=1,2
7823         do kkk=1,5
7824           do lll=1,3
7825 #ifdef MOMENT
7826             if (iii.eq.1) then
7827               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7828             else
7829               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7830             endif
7831 #endif
7832             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7833      &        auxvec(1))
7834             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7835             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7836      &        auxvec(1))
7837             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7838             call transpose2(EUg(1,1,k),auxmat(1,1))
7839             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7840      &        pizda(1,1))
7841             vv(1)=pizda(1,1)-pizda(2,2)
7842             vv(2)=pizda(1,2)+pizda(2,1)
7843             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7844 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7845 #ifdef MOMENT
7846             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7847 #else
7848             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7849 #endif
7850             if (swap) then
7851               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7852             else
7853               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7854             endif
7855           enddo
7856         enddo
7857       enddo
7858       return
7859       end
7860 c----------------------------------------------------------------------------
7861       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7862       implicit real*8 (a-h,o-z)
7863       include 'DIMENSIONS'
7864       include 'DIMENSIONS.ZSCOPT'
7865       include 'COMMON.IOUNITS'
7866       include 'COMMON.CHAIN'
7867       include 'COMMON.DERIV'
7868       include 'COMMON.INTERACT'
7869       include 'COMMON.CONTACTS'
7870       include 'COMMON.TORSION'
7871       include 'COMMON.VAR'
7872       include 'COMMON.GEO'
7873       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7874       logical swap
7875 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7876 C                                                                              C
7877 C      Parallel       Antiparallel                                             C
7878 C                                                                              C
7879 C          o             o                                                     C
7880 C         /l\   /   \   /j\                                                    C
7881 C        /   \ /     \ /   \                                                   C
7882 C       /| o |o       o| o |\                                                  C
7883 C       j|/k\|  /      |/k\|l /                                                C
7884 C        /   \ /       /   \ /                                                 C
7885 C       /     o       /     o                                                  C
7886 C       i             i                                                        C
7887 C                                                                              C
7888 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7889 C
7890 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7891 C           energy moment and not to the cluster cumulant.
7892       iti=itortyp(itype(i))
7893       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7894         itj1=itortyp(itype(j+1))
7895       else
7896         itj1=ntortyp+1
7897       endif
7898       itk=itortyp(itype(k))
7899       itk1=itortyp(itype(k+1))
7900       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7901         itl1=itortyp(itype(l+1))
7902       else
7903         itl1=ntortyp+1
7904       endif
7905 #ifdef MOMENT
7906       s1=dip(4,jj,i)*dip(4,kk,k)
7907 #endif
7908       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7909       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7910       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7911       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7912       call transpose2(EE(1,1,itk),auxmat(1,1))
7913       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7914       vv(1)=pizda(1,1)+pizda(2,2)
7915       vv(2)=pizda(2,1)-pizda(1,2)
7916       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7917 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7918 #ifdef MOMENT
7919       eello6_graph3=-(s1+s2+s3+s4)
7920 #else
7921       eello6_graph3=-(s2+s3+s4)
7922 #endif
7923 c      eello6_graph3=-s4
7924       if (.not. calc_grad) return
7925 C Derivatives in gamma(k-1)
7926       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7927       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7928       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7929       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7930 C Derivatives in gamma(l-1)
7931       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7932       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7933       call matmat2(auxmat(1,1),AECAderg(1,1,1),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       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7938 C Cartesian derivatives.
7939       do iii=1,2
7940         do kkk=1,5
7941           do lll=1,3
7942 #ifdef MOMENT
7943             if (iii.eq.1) then
7944               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7945             else
7946               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7947             endif
7948 #endif
7949             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7950      &        auxvec(1))
7951             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7952             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7953      &        auxvec(1))
7954             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7955             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7956      &        pizda(1,1))
7957             vv(1)=pizda(1,1)+pizda(2,2)
7958             vv(2)=pizda(2,1)-pizda(1,2)
7959             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7960 #ifdef MOMENT
7961             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7962 #else
7963             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7964 #endif
7965             if (swap) then
7966               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7967             else
7968               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7969             endif
7970 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7971           enddo
7972         enddo
7973       enddo
7974       return
7975       end
7976 c----------------------------------------------------------------------------
7977       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7978       implicit real*8 (a-h,o-z)
7979       include 'DIMENSIONS'
7980       include 'DIMENSIONS.ZSCOPT'
7981       include 'COMMON.IOUNITS'
7982       include 'COMMON.CHAIN'
7983       include 'COMMON.DERIV'
7984       include 'COMMON.INTERACT'
7985       include 'COMMON.CONTACTS'
7986       include 'COMMON.TORSION'
7987       include 'COMMON.VAR'
7988       include 'COMMON.GEO'
7989       include 'COMMON.FFIELD'
7990       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7991      & auxvec1(2),auxmat1(2,2)
7992       logical swap
7993 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7994 C                                                                              C
7995 C      Parallel       Antiparallel                                             C
7996 C                                                                              C
7997 C          o             o                                                     C
7998 C         /l\   /   \   /j\                                                    C
7999 C        /   \ /     \ /   \                                                   C
8000 C       /| o |o       o| o |\                                                  C
8001 C     \ j|/k\|      \  |/k\|l                                                  C
8002 C      \ /   \       \ /   \                                                   C
8003 C       o     \       o     \                                                  C
8004 C       i             i                                                        C
8005 C                                                                              C
8006 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8007 C
8008 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8009 C           energy moment and not to the cluster cumulant.
8010 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8011       iti=itortyp(itype(i))
8012       itj=itortyp(itype(j))
8013       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
8014         itj1=itortyp(itype(j+1))
8015       else
8016         itj1=ntortyp+1
8017       endif
8018       itk=itortyp(itype(k))
8019       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
8020         itk1=itortyp(itype(k+1))
8021       else
8022         itk1=ntortyp+1
8023       endif
8024       itl=itortyp(itype(l))
8025       if (l.lt.nres-1) then
8026         itl1=itortyp(itype(l+1))
8027       else
8028         itl1=ntortyp+1
8029       endif
8030 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8031 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8032 cd     & ' itl',itl,' itl1',itl1
8033 #ifdef MOMENT
8034       if (imat.eq.1) then
8035         s1=dip(3,jj,i)*dip(3,kk,k)
8036       else
8037         s1=dip(2,jj,j)*dip(2,kk,l)
8038       endif
8039 #endif
8040       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8041       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8042       if (j.eq.l+1) then
8043         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8044         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8045       else
8046         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8047         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8048       endif
8049       call transpose2(EUg(1,1,k),auxmat(1,1))
8050       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8051       vv(1)=pizda(1,1)-pizda(2,2)
8052       vv(2)=pizda(2,1)+pizda(1,2)
8053       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8054 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8055 #ifdef MOMENT
8056       eello6_graph4=-(s1+s2+s3+s4)
8057 #else
8058       eello6_graph4=-(s2+s3+s4)
8059 #endif
8060       if (.not. calc_grad) return
8061 C Derivatives in gamma(i-1)
8062       if (i.gt.1) then
8063 #ifdef MOMENT
8064         if (imat.eq.1) then
8065           s1=dipderg(2,jj,i)*dip(3,kk,k)
8066         else
8067           s1=dipderg(4,jj,j)*dip(2,kk,l)
8068         endif
8069 #endif
8070         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8071         if (j.eq.l+1) then
8072           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8073           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8074         else
8075           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8076           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8077         endif
8078         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8079         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8080 cd          write (2,*) 'turn6 derivatives'
8081 #ifdef MOMENT
8082           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8083 #else
8084           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8085 #endif
8086         else
8087 #ifdef MOMENT
8088           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8089 #else
8090           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8091 #endif
8092         endif
8093       endif
8094 C Derivatives in gamma(k-1)
8095 #ifdef MOMENT
8096       if (imat.eq.1) then
8097         s1=dip(3,jj,i)*dipderg(2,kk,k)
8098       else
8099         s1=dip(2,jj,j)*dipderg(4,kk,l)
8100       endif
8101 #endif
8102       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8103       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8104       if (j.eq.l+1) then
8105         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8106         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8107       else
8108         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8109         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8110       endif
8111       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8112       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8113       vv(1)=pizda(1,1)-pizda(2,2)
8114       vv(2)=pizda(2,1)+pizda(1,2)
8115       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8116       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8117 #ifdef MOMENT
8118         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8119 #else
8120         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8121 #endif
8122       else
8123 #ifdef MOMENT
8124         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8125 #else
8126         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8127 #endif
8128       endif
8129 C Derivatives in gamma(j-1) or gamma(l-1)
8130       if (l.eq.j+1 .and. l.gt.1) then
8131         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8132         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8133         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8134         vv(1)=pizda(1,1)-pizda(2,2)
8135         vv(2)=pizda(2,1)+pizda(1,2)
8136         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8137         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8138       else if (j.gt.1) then
8139         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8140         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8141         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8142         vv(1)=pizda(1,1)-pizda(2,2)
8143         vv(2)=pizda(2,1)+pizda(1,2)
8144         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8145         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8146           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8147         else
8148           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8149         endif
8150       endif
8151 C Cartesian derivatives.
8152       do iii=1,2
8153         do kkk=1,5
8154           do lll=1,3
8155 #ifdef MOMENT
8156             if (iii.eq.1) then
8157               if (imat.eq.1) then
8158                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8159               else
8160                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8161               endif
8162             else
8163               if (imat.eq.1) then
8164                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8165               else
8166                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8167               endif
8168             endif
8169 #endif
8170             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8171      &        auxvec(1))
8172             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8173             if (j.eq.l+1) then
8174               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8175      &          b1(1,itj1),auxvec(1))
8176               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8177             else
8178               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8179      &          b1(1,itl1),auxvec(1))
8180               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8181             endif
8182             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8183      &        pizda(1,1))
8184             vv(1)=pizda(1,1)-pizda(2,2)
8185             vv(2)=pizda(2,1)+pizda(1,2)
8186             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8187             if (swap) then
8188               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8189 #ifdef MOMENT
8190                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8191      &             -(s1+s2+s4)
8192 #else
8193                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8194      &             -(s2+s4)
8195 #endif
8196                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8197               else
8198 #ifdef MOMENT
8199                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8200 #else
8201                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8202 #endif
8203                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8204               endif
8205             else
8206 #ifdef MOMENT
8207               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8208 #else
8209               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8210 #endif
8211               if (l.eq.j+1) then
8212                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8213               else
8214                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8215               endif
8216             endif
8217           enddo
8218         enddo
8219       enddo
8220       return
8221       end
8222 c----------------------------------------------------------------------------
8223       double precision function eello_turn6(i,jj,kk)
8224       implicit real*8 (a-h,o-z)
8225       include 'DIMENSIONS'
8226       include 'DIMENSIONS.ZSCOPT'
8227       include 'COMMON.IOUNITS'
8228       include 'COMMON.CHAIN'
8229       include 'COMMON.DERIV'
8230       include 'COMMON.INTERACT'
8231       include 'COMMON.CONTACTS'
8232       include 'COMMON.TORSION'
8233       include 'COMMON.VAR'
8234       include 'COMMON.GEO'
8235       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8236      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8237      &  ggg1(3),ggg2(3)
8238       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8239      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8240 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8241 C           the respective energy moment and not to the cluster cumulant.
8242       eello_turn6=0.0d0
8243       j=i+4
8244       k=i+1
8245       l=i+3
8246       iti=itortyp(itype(i))
8247       itk=itortyp(itype(k))
8248       itk1=itortyp(itype(k+1))
8249       itl=itortyp(itype(l))
8250       itj=itortyp(itype(j))
8251 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8252 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8253 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8254 cd        eello6=0.0d0
8255 cd        return
8256 cd      endif
8257 cd      write (iout,*)
8258 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8259 cd     &   ' and',k,l
8260 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8261       do iii=1,2
8262         do kkk=1,5
8263           do lll=1,3
8264             derx_turn(lll,kkk,iii)=0.0d0
8265           enddo
8266         enddo
8267       enddo
8268 cd      eij=1.0d0
8269 cd      ekl=1.0d0
8270 cd      ekont=1.0d0
8271       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8272 cd      eello6_5=0.0d0
8273 cd      write (2,*) 'eello6_5',eello6_5
8274 #ifdef MOMENT
8275       call transpose2(AEA(1,1,1),auxmat(1,1))
8276       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8277       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8278       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8279 #else
8280       s1 = 0.0d0
8281 #endif
8282       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8283       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8284       s2 = scalar2(b1(1,itk),vtemp1(1))
8285 #ifdef MOMENT
8286       call transpose2(AEA(1,1,2),atemp(1,1))
8287       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8288       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8289       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8290 #else
8291       s8=0.0d0
8292 #endif
8293       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8294       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8295       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8296 #ifdef MOMENT
8297       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8298       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8299       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8300       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8301       ss13 = scalar2(b1(1,itk),vtemp4(1))
8302       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8303 #else
8304       s13=0.0d0
8305 #endif
8306 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8307 c      s1=0.0d0
8308 c      s2=0.0d0
8309 c      s8=0.0d0
8310 c      s12=0.0d0
8311 c      s13=0.0d0
8312       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8313       if (calc_grad) then
8314 C Derivatives in gamma(i+2)
8315 #ifdef MOMENT
8316       call transpose2(AEA(1,1,1),auxmatd(1,1))
8317       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8318       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8319       call transpose2(AEAderg(1,1,2),atempd(1,1))
8320       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8321       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8322 #else
8323       s8d=0.0d0
8324 #endif
8325       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8326       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8327       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8328 c      s1d=0.0d0
8329 c      s2d=0.0d0
8330 c      s8d=0.0d0
8331 c      s12d=0.0d0
8332 c      s13d=0.0d0
8333       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8334 C Derivatives in gamma(i+3)
8335 #ifdef MOMENT
8336       call transpose2(AEA(1,1,1),auxmatd(1,1))
8337       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8338       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8339       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8340 #else
8341       s1d=0.0d0
8342 #endif
8343       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8344       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8345       s2d = scalar2(b1(1,itk),vtemp1d(1))
8346 #ifdef MOMENT
8347       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8348       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8349 #endif
8350       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8351 #ifdef MOMENT
8352       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8353       call matmat2(gtempd(1,1),EUg(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+1)=gel_loc_turn6(i+1)
8365      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8366 #else
8367       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8368      &               -0.5d0*ekont*(s2d+s12d)
8369 #endif
8370 C Derivatives in gamma(i+4)
8371       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8372       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8373       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8374 #ifdef MOMENT
8375       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8376       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8377       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8378 #else
8379       s13d = 0.0d0
8380 #endif
8381 c      s1d=0.0d0
8382 c      s2d=0.0d0
8383 c      s8d=0.0d0
8384 C      s12d=0.0d0
8385 c      s13d=0.0d0
8386 #ifdef MOMENT
8387       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8388 #else
8389       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8390 #endif
8391 C Derivatives in gamma(i+5)
8392 #ifdef MOMENT
8393       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8394       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8395       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8396 #else
8397       s1d = 0.0d0
8398 #endif
8399       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8400       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8401       s2d = scalar2(b1(1,itk),vtemp1d(1))
8402 #ifdef MOMENT
8403       call transpose2(AEA(1,1,2),atempd(1,1))
8404       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8405       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8406 #else
8407       s8d = 0.0d0
8408 #endif
8409       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8410       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8411 #ifdef MOMENT
8412       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8413       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8414       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8415 #else
8416       s13d = 0.0d0
8417 #endif
8418 c      s1d=0.0d0
8419 c      s2d=0.0d0
8420 c      s8d=0.0d0
8421 c      s12d=0.0d0
8422 c      s13d=0.0d0
8423 #ifdef MOMENT
8424       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8425      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8426 #else
8427       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8428      &               -0.5d0*ekont*(s2d+s12d)
8429 #endif
8430 C Cartesian derivatives
8431       do iii=1,2
8432         do kkk=1,5
8433           do lll=1,3
8434 #ifdef MOMENT
8435             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8436             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8437             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8438 #else
8439             s1d = 0.0d0
8440 #endif
8441             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8442             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8443      &          vtemp1d(1))
8444             s2d = scalar2(b1(1,itk),vtemp1d(1))
8445 #ifdef MOMENT
8446             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8447             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8448             s8d = -(atempd(1,1)+atempd(2,2))*
8449      &           scalar2(cc(1,1,itl),vtemp2(1))
8450 #else
8451             s8d = 0.0d0
8452 #endif
8453             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8454      &           auxmatd(1,1))
8455             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8456             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8457 c      s1d=0.0d0
8458 c      s2d=0.0d0
8459 c      s8d=0.0d0
8460 c      s12d=0.0d0
8461 c      s13d=0.0d0
8462 #ifdef MOMENT
8463             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8464      &        - 0.5d0*(s1d+s2d)
8465 #else
8466             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8467      &        - 0.5d0*s2d
8468 #endif
8469 #ifdef MOMENT
8470             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8471      &        - 0.5d0*(s8d+s12d)
8472 #else
8473             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8474      &        - 0.5d0*s12d
8475 #endif
8476           enddo
8477         enddo
8478       enddo
8479 #ifdef MOMENT
8480       do kkk=1,5
8481         do lll=1,3
8482           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8483      &      achuj_tempd(1,1))
8484           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8485           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8486           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8487           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8488           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8489      &      vtemp4d(1))
8490           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8491           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8492           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8493         enddo
8494       enddo
8495 #endif
8496 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8497 cd     &  16*eel_turn6_num
8498 cd      goto 1112
8499       if (j.lt.nres-1) then
8500         j1=j+1
8501         j2=j-1
8502       else
8503         j1=j-1
8504         j2=j-2
8505       endif
8506       if (l.lt.nres-1) then
8507         l1=l+1
8508         l2=l-1
8509       else
8510         l1=l-1
8511         l2=l-2
8512       endif
8513       do ll=1,3
8514         ggg1(ll)=eel_turn6*g_contij(ll,1)
8515         ggg2(ll)=eel_turn6*g_contij(ll,2)
8516         ghalf=0.5d0*ggg1(ll)
8517 cd        ghalf=0.0d0
8518         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8519      &    +ekont*derx_turn(ll,2,1)
8520         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8521         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8522      &    +ekont*derx_turn(ll,4,1)
8523         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8524         ghalf=0.5d0*ggg2(ll)
8525 cd        ghalf=0.0d0
8526         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8527      &    +ekont*derx_turn(ll,2,2)
8528         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8529         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8530      &    +ekont*derx_turn(ll,4,2)
8531         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8532       enddo
8533 cd      goto 1112
8534       do m=i+1,j-1
8535         do ll=1,3
8536           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8537         enddo
8538       enddo
8539       do m=k+1,l-1
8540         do ll=1,3
8541           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8542         enddo
8543       enddo
8544 1112  continue
8545       do m=i+2,j2
8546         do ll=1,3
8547           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8548         enddo
8549       enddo
8550       do m=k+2,l2
8551         do ll=1,3
8552           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8553         enddo
8554       enddo
8555 cd      do iii=1,nres-3
8556 cd        write (2,*) iii,g_corr6_loc(iii)
8557 cd      enddo
8558       endif
8559       eello_turn6=ekont*eel_turn6
8560 cd      write (2,*) 'ekont',ekont
8561 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8562       return
8563       end
8564 crc-------------------------------------------------
8565 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8566       subroutine Eliptransfer(eliptran)
8567       implicit real*8 (a-h,o-z)
8568       include 'DIMENSIONS'
8569       include 'COMMON.GEO'
8570       include 'COMMON.VAR'
8571       include 'COMMON.LOCAL'
8572       include 'COMMON.CHAIN'
8573       include 'COMMON.DERIV'
8574       include 'COMMON.INTERACT'
8575       include 'COMMON.IOUNITS'
8576       include 'COMMON.CALC'
8577       include 'COMMON.CONTROL'
8578       include 'COMMON.SPLITELE'
8579       include 'COMMON.SBRIDGE'
8580 C this is done by Adasko
8581 C      print *,"wchodze"
8582 C structure of box:
8583 C      water
8584 C--bordliptop-- buffore starts
8585 C--bufliptop--- here true lipid starts
8586 C      lipid
8587 C--buflipbot--- lipid ends buffore starts
8588 C--bordlipbot--buffore ends
8589       eliptran=0.0
8590       do i=1,nres
8591 C       do i=1,1
8592         if (itype(i).eq.ntyp1) cycle
8593
8594         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8595         if (positi.le.0) positi=positi+boxzsize
8596 C        print *,i
8597 C first for peptide groups
8598 c for each residue check if it is in lipid or lipid water border area
8599        if ((positi.gt.bordlipbot)
8600      &.and.(positi.lt.bordliptop)) then
8601 C the energy transfer exist
8602         if (positi.lt.buflipbot) then
8603 C what fraction I am in
8604          fracinbuf=1.0d0-
8605      &        ((positi-bordlipbot)/lipbufthick)
8606 C lipbufthick is thickenes of lipid buffore
8607          sslip=sscalelip(fracinbuf)
8608          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8609          eliptran=eliptran+sslip*pepliptran
8610          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8611          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8612 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8613         elseif (positi.gt.bufliptop) then
8614          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8615          sslip=sscalelip(fracinbuf)
8616          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8617          eliptran=eliptran+sslip*pepliptran
8618          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8619          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8620 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8621 C          print *, "doing sscalefor top part"
8622 C         print *,i,sslip,fracinbuf,ssgradlip
8623         else
8624          eliptran=eliptran+pepliptran
8625 C         print *,"I am in true lipid"
8626         endif
8627 C       else
8628 C       eliptran=elpitran+0.0 ! I am in water
8629        endif
8630        enddo
8631 C       print *, "nic nie bylo w lipidzie?"
8632 C now multiply all by the peptide group transfer factor
8633 C       eliptran=eliptran*pepliptran
8634 C now the same for side chains
8635 CV       do i=1,1
8636        do i=1,nres
8637         if (itype(i).eq.ntyp1) cycle
8638         positi=(mod(c(3,i+nres),boxzsize))
8639         if (positi.le.0) positi=positi+boxzsize
8640 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8641 c for each residue check if it is in lipid or lipid water border area
8642 C       respos=mod(c(3,i+nres),boxzsize)
8643 C       print *,positi,bordlipbot,buflipbot
8644        if ((positi.gt.bordlipbot)
8645      & .and.(positi.lt.bordliptop)) then
8646 C the energy transfer exist
8647         if (positi.lt.buflipbot) then
8648          fracinbuf=1.0d0-
8649      &     ((positi-bordlipbot)/lipbufthick)
8650 C lipbufthick is thickenes of lipid buffore
8651          sslip=sscalelip(fracinbuf)
8652          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8653          eliptran=eliptran+sslip*liptranene(itype(i))
8654          gliptranx(3,i)=gliptranx(3,i)
8655      &+ssgradlip*liptranene(itype(i))
8656          gliptranc(3,i-1)= gliptranc(3,i-1)
8657      &+ssgradlip*liptranene(itype(i))
8658 C         print *,"doing sccale for lower part"
8659         elseif (positi.gt.bufliptop) then
8660          fracinbuf=1.0d0-
8661      &((bordliptop-positi)/lipbufthick)
8662          sslip=sscalelip(fracinbuf)
8663          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8664          eliptran=eliptran+sslip*liptranene(itype(i))
8665          gliptranx(3,i)=gliptranx(3,i)
8666      &+ssgradlip*liptranene(itype(i))
8667          gliptranc(3,i-1)= gliptranc(3,i-1)
8668      &+ssgradlip*liptranene(itype(i))
8669 C          print *, "doing sscalefor top part",sslip,fracinbuf
8670         else
8671          eliptran=eliptran+liptranene(itype(i))
8672 C         print *,"I am in true lipid"
8673         endif
8674         endif ! if in lipid or buffor
8675 C       else
8676 C       eliptran=elpitran+0.0 ! I am in water
8677        enddo
8678        return
8679        end
8680
8681
8682 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8683
8684       SUBROUTINE MATVEC2(A1,V1,V2)
8685       implicit real*8 (a-h,o-z)
8686       include 'DIMENSIONS'
8687       DIMENSION A1(2,2),V1(2),V2(2)
8688 c      DO 1 I=1,2
8689 c        VI=0.0
8690 c        DO 3 K=1,2
8691 c    3     VI=VI+A1(I,K)*V1(K)
8692 c        Vaux(I)=VI
8693 c    1 CONTINUE
8694
8695       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8696       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8697
8698       v2(1)=vaux1
8699       v2(2)=vaux2
8700       END
8701 C---------------------------------------
8702       SUBROUTINE MATMAT2(A1,A2,A3)
8703       implicit real*8 (a-h,o-z)
8704       include 'DIMENSIONS'
8705       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8706 c      DIMENSION AI3(2,2)
8707 c        DO  J=1,2
8708 c          A3IJ=0.0
8709 c          DO K=1,2
8710 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8711 c          enddo
8712 c          A3(I,J)=A3IJ
8713 c       enddo
8714 c      enddo
8715
8716       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8717       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8718       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8719       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8720
8721       A3(1,1)=AI3_11
8722       A3(2,1)=AI3_21
8723       A3(1,2)=AI3_12
8724       A3(2,2)=AI3_22
8725       END
8726
8727 c-------------------------------------------------------------------------
8728       double precision function scalar2(u,v)
8729       implicit none
8730       double precision u(2),v(2)
8731       double precision sc
8732       integer i
8733       scalar2=u(1)*v(1)+u(2)*v(2)
8734       return
8735       end
8736
8737 C-----------------------------------------------------------------------------
8738
8739       subroutine transpose2(a,at)
8740       implicit none
8741       double precision a(2,2),at(2,2)
8742       at(1,1)=a(1,1)
8743       at(1,2)=a(2,1)
8744       at(2,1)=a(1,2)
8745       at(2,2)=a(2,2)
8746       return
8747       end
8748 c--------------------------------------------------------------------------
8749       subroutine transpose(n,a,at)
8750       implicit none
8751       integer n,i,j
8752       double precision a(n,n),at(n,n)
8753       do i=1,n
8754         do j=1,n
8755           at(j,i)=a(i,j)
8756         enddo
8757       enddo
8758       return
8759       end
8760 C---------------------------------------------------------------------------
8761       subroutine prodmat3(a1,a2,kk,transp,prod)
8762       implicit none
8763       integer i,j
8764       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8765       logical transp
8766 crc      double precision auxmat(2,2),prod_(2,2)
8767
8768       if (transp) then
8769 crc        call transpose2(kk(1,1),auxmat(1,1))
8770 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8771 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8772
8773            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8774      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8775            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8776      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8777            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8778      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8779            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8780      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8781
8782       else
8783 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8784 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8785
8786            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8787      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8788            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8789      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8790            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8791      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8792            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8793      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8794
8795       endif
8796 c      call transpose2(a2(1,1),a2t(1,1))
8797
8798 crc      print *,transp
8799 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8800 crc      print *,((prod(i,j),i=1,2),j=1,2)
8801
8802       return
8803       end
8804 C-----------------------------------------------------------------------------
8805       double precision function scalar(u,v)
8806       implicit none
8807       double precision u(3),v(3)
8808       double precision sc
8809       integer i
8810       sc=0.0d0
8811       do i=1,3
8812         sc=sc+u(i)*v(i)
8813       enddo
8814       scalar=sc
8815       return
8816       end
8817 C-----------------------------------------------------------------------
8818       double precision function sscale(r)
8819       double precision r,gamm
8820       include "COMMON.SPLITELE"
8821       if(r.lt.r_cut-rlamb) then
8822         sscale=1.0d0
8823       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8824         gamm=(r-(r_cut-rlamb))/rlamb
8825         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8826       else
8827         sscale=0d0
8828       endif
8829       return
8830       end
8831 C-----------------------------------------------------------------------
8832 C-----------------------------------------------------------------------
8833       double precision function sscagrad(r)
8834       double precision r,gamm
8835       include "COMMON.SPLITELE"
8836       if(r.lt.r_cut-rlamb) then
8837         sscagrad=0.0d0
8838       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8839         gamm=(r-(r_cut-rlamb))/rlamb
8840         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8841       else
8842         sscagrad=0.0d0
8843       endif
8844       return
8845       end
8846 C-----------------------------------------------------------------------
8847 C-----------------------------------------------------------------------
8848       double precision function sscalelip(r)
8849       double precision r,gamm
8850       include "COMMON.SPLITELE"
8851 C      if(r.lt.r_cut-rlamb) then
8852 C        sscale=1.0d0
8853 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8854 C        gamm=(r-(r_cut-rlamb))/rlamb
8855         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8856 C      else
8857 C        sscale=0d0
8858 C      endif
8859       return
8860       end
8861 C-----------------------------------------------------------------------
8862       double precision function sscagradlip(r)
8863       double precision r,gamm
8864       include "COMMON.SPLITELE"
8865 C     if(r.lt.r_cut-rlamb) then
8866 C        sscagrad=0.0d0
8867 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8868 C        gamm=(r-(r_cut-rlamb))/rlamb
8869         sscagradlip=r*(6*r-6.0d0)
8870 C      else
8871 C        sscagrad=0.0d0
8872 C      endif
8873       return
8874       end
8875
8876 C-----------------------------------------------------------------------
8877        subroutine set_shield_fac
8878       implicit real*8 (a-h,o-z)
8879       include 'DIMENSIONS'
8880       include 'COMMON.CHAIN'
8881       include 'COMMON.DERIV'
8882       include 'COMMON.IOUNITS'
8883       include 'COMMON.SHIELD'
8884       include 'COMMON.INTERACT'
8885 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8886       double precision div77_81/0.974996043d0/,
8887      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8888
8889 C the vector between center of side_chain and peptide group
8890        double precision pep_side(3),long,side_calf(3),
8891      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8892      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8893 C the line belowe needs to be changed for FGPROC>1
8894       do i=1,nres-1
8895       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8896       ishield_list(i)=0
8897 Cif there two consequtive dummy atoms there is no peptide group between them
8898 C the line below has to be changed for FGPROC>1
8899       VolumeTotal=0.0
8900       do k=1,nres
8901        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8902        dist_pep_side=0.0
8903        dist_side_calf=0.0
8904        do j=1,3
8905 C first lets set vector conecting the ithe side-chain with kth side-chain
8906       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8907 C      pep_side(j)=2.0d0
8908 C and vector conecting the side-chain with its proper calfa
8909       side_calf(j)=c(j,k+nres)-c(j,k)
8910 C      side_calf(j)=2.0d0
8911       pept_group(j)=c(j,i)-c(j,i+1)
8912 C lets have their lenght
8913       dist_pep_side=pep_side(j)**2+dist_pep_side
8914       dist_side_calf=dist_side_calf+side_calf(j)**2
8915       dist_pept_group=dist_pept_group+pept_group(j)**2
8916       enddo
8917        dist_pep_side=dsqrt(dist_pep_side)
8918        dist_pept_group=dsqrt(dist_pept_group)
8919        dist_side_calf=dsqrt(dist_side_calf)
8920       do j=1,3
8921         pep_side_norm(j)=pep_side(j)/dist_pep_side
8922         side_calf_norm(j)=dist_side_calf
8923       enddo
8924 C now sscale fraction
8925        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8926 C       print *,buff_shield,"buff"
8927 C now sscale
8928         if (sh_frac_dist.le.0.0) cycle
8929 C If we reach here it means that this side chain reaches the shielding sphere
8930 C Lets add him to the list for gradient
8931         ishield_list(i)=ishield_list(i)+1
8932 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8933 C this list is essential otherwise problem would be O3
8934         shield_list(ishield_list(i),i)=k
8935 C Lets have the sscale value
8936         if (sh_frac_dist.gt.1.0) then
8937          scale_fac_dist=1.0d0
8938          do j=1,3
8939          sh_frac_dist_grad(j)=0.0d0
8940          enddo
8941         else
8942          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8943      &                   *(2.0*sh_frac_dist-3.0d0)
8944          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8945      &                  /dist_pep_side/buff_shield*0.5
8946 C remember for the final gradient multiply sh_frac_dist_grad(j)
8947 C for side_chain by factor -2 !
8948          do j=1,3
8949          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8950 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8951 C     &                    sh_frac_dist_grad(j)
8952          enddo
8953         endif
8954 C        if ((i.eq.3).and.(k.eq.2)) then
8955 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8956 C     & ,"TU"
8957 C        endif
8958
8959 C this is what is now we have the distance scaling now volume...
8960       short=short_r_sidechain(itype(k))
8961       long=long_r_sidechain(itype(k))
8962       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8963 C now costhet_grad
8964 C       costhet=0.0d0
8965        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8966 C       costhet_fac=0.0d0
8967        do j=1,3
8968          costhet_grad(j)=costhet_fac*pep_side(j)
8969        enddo
8970 C remember for the final gradient multiply costhet_grad(j)
8971 C for side_chain by factor -2 !
8972 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8973 C pep_side0pept_group is vector multiplication
8974       pep_side0pept_group=0.0
8975       do j=1,3
8976       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8977       enddo
8978       cosalfa=(pep_side0pept_group/
8979      & (dist_pep_side*dist_side_calf))
8980       fac_alfa_sin=1.0-cosalfa**2
8981       fac_alfa_sin=dsqrt(fac_alfa_sin)
8982       rkprim=fac_alfa_sin*(long-short)+short
8983 C now costhet_grad
8984        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8985        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8986
8987        do j=1,3
8988          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8989      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8990      &*(long-short)/fac_alfa_sin*cosalfa/
8991      &((dist_pep_side*dist_side_calf))*
8992      &((side_calf(j))-cosalfa*
8993      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8994
8995         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8996      &*(long-short)/fac_alfa_sin*cosalfa
8997      &/((dist_pep_side*dist_side_calf))*
8998      &(pep_side(j)-
8999      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9000        enddo
9001
9002       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9003      &                    /VSolvSphere_div
9004      &                    *wshield
9005 C now the gradient...
9006 C grad_shield is gradient of Calfa for peptide groups
9007 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9008 C     &               costhet,cosphi
9009 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9010 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9011       do j=1,3
9012       grad_shield(j,i)=grad_shield(j,i)
9013 C gradient po skalowaniu
9014      &                +(sh_frac_dist_grad(j)
9015 C  gradient po costhet
9016      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9017      &-scale_fac_dist*(cosphi_grad_long(j))
9018      &/(1.0-cosphi) )*div77_81
9019      &*VofOverlap
9020 C grad_shield_side is Cbeta sidechain gradient
9021       grad_shield_side(j,ishield_list(i),i)=
9022      &        (sh_frac_dist_grad(j)*-2.0d0
9023      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9024      &       +scale_fac_dist*(cosphi_grad_long(j))
9025      &        *2.0d0/(1.0-cosphi))
9026      &        *div77_81*VofOverlap
9027
9028        grad_shield_loc(j,ishield_list(i),i)=
9029      &   scale_fac_dist*cosphi_grad_loc(j)
9030      &        *2.0d0/(1.0-cosphi)
9031      &        *div77_81*VofOverlap
9032       enddo
9033       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9034       enddo
9035       fac_shield(i)=VolumeTotal*div77_81+div4_81
9036 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9037       enddo
9038       return
9039       end
9040 C--------------------------------------------------------------------------
9041 C first for shielding is setting of function of side-chains
9042        subroutine set_shield_fac2
9043       implicit real*8 (a-h,o-z)
9044       include 'DIMENSIONS'
9045       include 'COMMON.CHAIN'
9046       include 'COMMON.DERIV'
9047       include 'COMMON.IOUNITS'
9048       include 'COMMON.SHIELD'
9049       include 'COMMON.INTERACT'
9050 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9051       double precision div77_81/0.974996043d0/,
9052      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9053
9054 C the vector between center of side_chain and peptide group
9055        double precision pep_side(3),long,side_calf(3),
9056      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9057      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9058 C the line belowe needs to be changed for FGPROC>1
9059       do i=1,nres-1
9060       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9061       ishield_list(i)=0
9062 Cif there two consequtive dummy atoms there is no peptide group between them
9063 C the line below has to be changed for FGPROC>1
9064       VolumeTotal=0.0
9065       do k=1,nres
9066        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9067        dist_pep_side=0.0
9068        dist_side_calf=0.0
9069        do j=1,3
9070 C first lets set vector conecting the ithe side-chain with kth side-chain
9071       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9072 C      pep_side(j)=2.0d0
9073 C and vector conecting the side-chain with its proper calfa
9074       side_calf(j)=c(j,k+nres)-c(j,k)
9075 C      side_calf(j)=2.0d0
9076       pept_group(j)=c(j,i)-c(j,i+1)
9077 C lets have their lenght
9078       dist_pep_side=pep_side(j)**2+dist_pep_side
9079       dist_side_calf=dist_side_calf+side_calf(j)**2
9080       dist_pept_group=dist_pept_group+pept_group(j)**2
9081       enddo
9082        dist_pep_side=dsqrt(dist_pep_side)
9083        dist_pept_group=dsqrt(dist_pept_group)
9084        dist_side_calf=dsqrt(dist_side_calf)
9085       do j=1,3
9086         pep_side_norm(j)=pep_side(j)/dist_pep_side
9087         side_calf_norm(j)=dist_side_calf
9088       enddo
9089 C now sscale fraction
9090        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9091 C       print *,buff_shield,"buff"
9092 C now sscale
9093         if (sh_frac_dist.le.0.0) cycle
9094 C If we reach here it means that this side chain reaches the shielding sphere
9095 C Lets add him to the list for gradient
9096         ishield_list(i)=ishield_list(i)+1
9097 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9098 C this list is essential otherwise problem would be O3
9099         shield_list(ishield_list(i),i)=k
9100 C Lets have the sscale value
9101         if (sh_frac_dist.gt.1.0) then
9102          scale_fac_dist=1.0d0
9103          do j=1,3
9104          sh_frac_dist_grad(j)=0.0d0
9105          enddo
9106         else
9107          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9108      &                   *(2.0d0*sh_frac_dist-3.0d0)
9109          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9110      &                  /dist_pep_side/buff_shield*0.5d0
9111 C remember for the final gradient multiply sh_frac_dist_grad(j)
9112 C for side_chain by factor -2 !
9113          do j=1,3
9114          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9115 C         sh_frac_dist_grad(j)=0.0d0
9116 C         scale_fac_dist=1.0d0
9117 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9118 C     &                    sh_frac_dist_grad(j)
9119          enddo
9120         endif
9121 C this is what is now we have the distance scaling now volume...
9122       short=short_r_sidechain(itype(k))
9123       long=long_r_sidechain(itype(k))
9124       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9125       sinthet=short/dist_pep_side*costhet
9126 C now costhet_grad
9127 C       costhet=0.6d0
9128 C       sinthet=0.8
9129        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9130 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9131 C     &             -short/dist_pep_side**2/costhet)
9132 C       costhet_fac=0.0d0
9133        do j=1,3
9134          costhet_grad(j)=costhet_fac*pep_side(j)
9135        enddo
9136 C remember for the final gradient multiply costhet_grad(j)
9137 C for side_chain by factor -2 !
9138 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9139 C pep_side0pept_group is vector multiplication
9140       pep_side0pept_group=0.0d0
9141       do j=1,3
9142       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9143       enddo
9144       cosalfa=(pep_side0pept_group/
9145      & (dist_pep_side*dist_side_calf))
9146       fac_alfa_sin=1.0d0-cosalfa**2
9147       fac_alfa_sin=dsqrt(fac_alfa_sin)
9148       rkprim=fac_alfa_sin*(long-short)+short
9149 C      rkprim=short
9150
9151 C now costhet_grad
9152        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9153 C       cosphi=0.6
9154        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9155        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9156      &      dist_pep_side**2)
9157 C       sinphi=0.8
9158        do j=1,3
9159          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9160      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9161      &*(long-short)/fac_alfa_sin*cosalfa/
9162      &((dist_pep_side*dist_side_calf))*
9163      &((side_calf(j))-cosalfa*
9164      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9165 C       cosphi_grad_long(j)=0.0d0
9166         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9167      &*(long-short)/fac_alfa_sin*cosalfa
9168      &/((dist_pep_side*dist_side_calf))*
9169      &(pep_side(j)-
9170      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9171 C       cosphi_grad_loc(j)=0.0d0
9172        enddo
9173 C      print *,sinphi,sinthet
9174       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9175      &                    /VSolvSphere_div
9176 C     &                    *wshield
9177 C now the gradient...
9178       do j=1,3
9179       grad_shield(j,i)=grad_shield(j,i)
9180 C gradient po skalowaniu
9181      &                +(sh_frac_dist_grad(j)*VofOverlap
9182 C  gradient po costhet
9183      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9184      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9185      &       sinphi/sinthet*costhet*costhet_grad(j)
9186      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9187      & )*wshield
9188 C grad_shield_side is Cbeta sidechain gradient
9189       grad_shield_side(j,ishield_list(i),i)=
9190      &        (sh_frac_dist_grad(j)*-2.0d0
9191      &        *VofOverlap
9192      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9193      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9194      &       sinphi/sinthet*costhet*costhet_grad(j)
9195      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9196      &       )*wshield
9197
9198        grad_shield_loc(j,ishield_list(i),i)=
9199      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9200      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9201      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9202      &        ))
9203      &        *wshield
9204       enddo
9205       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9206       enddo
9207       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9208 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9209 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9210       enddo
9211       return
9212       end
9213
9214 C-----------------------------------------------------------------------
9215 C-----------------------------------------------------------
9216 C This subroutine is to mimic the histone like structure but as well can be
9217 C utilizet to nanostructures (infinit) small modification has to be used to
9218 C make it finite (z gradient at the ends has to be changes as well as the x,y
9219 C gradient has to be modified at the ends
9220 C The energy function is Kihara potential
9221 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9222 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9223 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9224 C simple Kihara potential
9225       subroutine calctube(Etube)
9226        implicit real*8 (a-h,o-z)
9227       include 'DIMENSIONS'
9228       include 'COMMON.GEO'
9229       include 'COMMON.VAR'
9230       include 'COMMON.LOCAL'
9231       include 'COMMON.CHAIN'
9232       include 'COMMON.DERIV'
9233       include 'COMMON.INTERACT'
9234       include 'COMMON.IOUNITS'
9235       include 'COMMON.CALC'
9236       include 'COMMON.CONTROL'
9237       include 'COMMON.SPLITELE'
9238       include 'COMMON.SBRIDGE'
9239       double precision tub_r,vectube(3),enetube(maxres*2)
9240       Etube=0.0d0
9241       do i=itube_start,itube_end
9242         enetube(i)=0.0d0
9243         enetube(i+nres)=0.0d0
9244       enddo
9245 C first we calculate the distance from tube center
9246 C first sugare-phosphate group for NARES this would be peptide group
9247 C for UNRES
9248        do i=itube_start,itube_end
9249 C lets ommit dummy atoms for now
9250        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9251 C now calculate distance from center of tube and direction vectors
9252       xmin=boxxsize
9253       ymin=boxysize
9254         do j=-1,1
9255          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9256          vectube(1)=vectube(1)+boxxsize*j
9257          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9258          vectube(2)=vectube(2)+boxysize*j
9259
9260          xminact=abs(vectube(1)-tubecenter(1))
9261          yminact=abs(vectube(2)-tubecenter(2))
9262            if (xmin.gt.xminact) then
9263             xmin=xminact
9264             xtemp=vectube(1)
9265            endif
9266            if (ymin.gt.yminact) then
9267              ymin=yminact
9268              ytemp=vectube(2)
9269             endif
9270          enddo
9271       vectube(1)=xtemp
9272       vectube(2)=ytemp
9273       vectube(1)=vectube(1)-tubecenter(1)
9274       vectube(2)=vectube(2)-tubecenter(2)
9275
9276 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9277 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9278
9279 C as the tube is infinity we do not calculate the Z-vector use of Z
9280 C as chosen axis
9281       vectube(3)=0.0d0
9282 C now calculte the distance
9283        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9284 C now normalize vector
9285       vectube(1)=vectube(1)/tub_r
9286       vectube(2)=vectube(2)/tub_r
9287 C calculte rdiffrence between r and r0
9288       rdiff=tub_r-tubeR0
9289 C and its 6 power
9290       rdiff6=rdiff**6.0d0
9291 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9292        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
9293 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9294 C       print *,rdiff,rdiff6,pep_aa_tube
9295 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9296 C now we calculate gradient
9297        fac=(-12.0d0*pep_aa_tube/rdiff6-
9298      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
9299 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9300 C     &rdiff,fac
9301
9302 C now direction of gg_tube vector
9303         do j=1,3
9304         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9305         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9306         enddo
9307         enddo
9308 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
9309 C        print *,gg_tube(1,0),"TU"
9310
9311
9312        do i=itube_start,itube_end
9313 C Lets not jump over memory as we use many times iti
9314          iti=itype(i)
9315 C lets ommit dummy atoms for now
9316          if ((iti.eq.ntyp1)
9317 C in UNRES uncomment the line below as GLY has no side-chain...
9318 C      .or.(iti.eq.10)
9319      &   ) cycle
9320       xmin=boxxsize
9321       ymin=boxysize
9322         do j=-1,1
9323          vectube(1)=mod((c(1,i+nres)),boxxsize)
9324          vectube(1)=vectube(1)+boxxsize*j
9325          vectube(2)=mod((c(2,i+nres)),boxysize)
9326          vectube(2)=vectube(2)+boxysize*j
9327
9328          xminact=abs(vectube(1)-tubecenter(1))
9329          yminact=abs(vectube(2)-tubecenter(2))
9330            if (xmin.gt.xminact) then
9331             xmin=xminact
9332             xtemp=vectube(1)
9333            endif
9334            if (ymin.gt.yminact) then
9335              ymin=yminact
9336              ytemp=vectube(2)
9337             endif
9338          enddo
9339       vectube(1)=xtemp
9340       vectube(2)=ytemp
9341 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
9342 C     &     tubecenter(2)
9343       vectube(1)=vectube(1)-tubecenter(1)
9344       vectube(2)=vectube(2)-tubecenter(2)
9345
9346 C as the tube is infinity we do not calculate the Z-vector use of Z
9347 C as chosen axis
9348       vectube(3)=0.0d0
9349 C now calculte the distance
9350        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9351 C now normalize vector
9352       vectube(1)=vectube(1)/tub_r
9353       vectube(2)=vectube(2)/tub_r
9354
9355 C calculte rdiffrence between r and r0
9356       rdiff=tub_r-tubeR0
9357 C and its 6 power
9358       rdiff6=rdiff**6.0d0
9359 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9360        sc_aa_tube=sc_aa_tube_par(iti)
9361        sc_bb_tube=sc_bb_tube_par(iti)
9362        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
9363 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9364 C now we calculate gradient
9365        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9366      &       6.0d0*sc_bb_tube/rdiff6/rdiff
9367 C now direction of gg_tube vector
9368          do j=1,3
9369           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9370           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9371          enddo
9372         enddo
9373         do i=itube_start,itube_end
9374           Etube=Etube+enetube(i)+enetube(i+nres)
9375         enddo
9376 C        print *,"ETUBE", etube
9377         return
9378         end
9379 C TO DO 1) add to total energy
9380 C       2) add to gradient summation
9381 C       3) add reading parameters (AND of course oppening of PARAM file)
9382 C       4) add reading the center of tube
9383 C       5) add COMMONs
9384 C       6) add to zerograd
9385
9386 C-----------------------------------------------------------------------
9387 C-----------------------------------------------------------
9388 C This subroutine is to mimic the histone like structure but as well can be
9389 C utilizet to nanostructures (infinit) small modification has to be used to
9390 C make it finite (z gradient at the ends has to be changes as well as the x,y
9391 C gradient has to be modified at the ends
9392 C The energy function is Kihara potential
9393 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9394 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9395 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9396 C simple Kihara potential
9397       subroutine calctube2(Etube)
9398        implicit real*8 (a-h,o-z)
9399       include 'DIMENSIONS'
9400       include 'COMMON.GEO'
9401       include 'COMMON.VAR'
9402       include 'COMMON.LOCAL'
9403       include 'COMMON.CHAIN'
9404       include 'COMMON.DERIV'
9405       include 'COMMON.INTERACT'
9406       include 'COMMON.IOUNITS'
9407       include 'COMMON.CALC'
9408       include 'COMMON.CONTROL'
9409       include 'COMMON.SPLITELE'
9410       include 'COMMON.SBRIDGE'
9411       double precision tub_r,vectube(3),enetube(maxres*2)
9412       Etube=0.0d0
9413       do i=itube_start,itube_end
9414         enetube(i)=0.0d0
9415         enetube(i+nres)=0.0d0
9416       enddo
9417 C first we calculate the distance from tube center
9418 C first sugare-phosphate group for NARES this would be peptide group
9419 C for UNRES
9420        do i=itube_start,itube_end
9421 C lets ommit dummy atoms for now
9422
9423        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9424 C now calculate distance from center of tube and direction vectors
9425 C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9426 C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
9427 C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9428 C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
9429       xmin=boxxsize
9430       ymin=boxysize
9431         do j=-1,1
9432          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9433          vectube(1)=vectube(1)+boxxsize*j
9434          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9435          vectube(2)=vectube(2)+boxysize*j
9436
9437          xminact=abs(vectube(1)-tubecenter(1))
9438          yminact=abs(vectube(2)-tubecenter(2))
9439            if (xmin.gt.xminact) then
9440             xmin=xminact
9441             xtemp=vectube(1)
9442            endif
9443            if (ymin.gt.yminact) then
9444              ymin=yminact
9445              ytemp=vectube(2)
9446             endif
9447          enddo
9448       vectube(1)=xtemp
9449       vectube(2)=ytemp
9450       vectube(1)=vectube(1)-tubecenter(1)
9451       vectube(2)=vectube(2)-tubecenter(2)
9452
9453 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9454 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9455
9456 C as the tube is infinity we do not calculate the Z-vector use of Z
9457 C as chosen axis
9458       vectube(3)=0.0d0
9459 C now calculte the distance
9460        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9461 C now normalize vector
9462       vectube(1)=vectube(1)/tub_r
9463       vectube(2)=vectube(2)/tub_r
9464 C calculte rdiffrence between r and r0
9465       rdiff=tub_r-tubeR0
9466 C and its 6 power
9467       rdiff6=rdiff**6.0d0
9468 C THIS FRAGMENT MAKES TUBE FINITE
9469         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
9470         if (positi.le.0) positi=positi+boxzsize
9471 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9472 c for each residue check if it is in lipid or lipid water border area
9473 C       respos=mod(c(3,i+nres),boxzsize)
9474        print *,positi,bordtubebot,buftubebot,bordtubetop
9475        if ((positi.gt.bordtubebot)
9476      & .and.(positi.lt.bordtubetop)) then
9477 C the energy transfer exist
9478         if (positi.lt.buftubebot) then
9479          fracinbuf=1.0d0-
9480      &     ((positi-bordtubebot)/tubebufthick)
9481 C lipbufthick is thickenes of lipid buffore
9482          sstube=sscalelip(fracinbuf)
9483          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
9484          print *,ssgradtube, sstube,tubetranene(itype(i))
9485          enetube(i)=enetube(i)+sstube*tubetranenepep
9486 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9487 C     &+ssgradtube*tubetranene(itype(i))
9488 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9489 C     &+ssgradtube*tubetranene(itype(i))
9490 C         print *,"doing sccale for lower part"
9491         elseif (positi.gt.buftubetop) then
9492          fracinbuf=1.0d0-
9493      &((bordtubetop-positi)/tubebufthick)
9494          sstube=sscalelip(fracinbuf)
9495          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
9496          enetube(i)=enetube(i)+sstube*tubetranenepep
9497 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9498 C     &+ssgradtube*tubetranene(itype(i))
9499 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9500 C     &+ssgradtube*tubetranene(itype(i))
9501 C          print *, "doing sscalefor top part",sslip,fracinbuf
9502         else
9503          sstube=1.0d0
9504          ssgradtube=0.0d0
9505          enetube(i)=enetube(i)+sstube*tubetranenepep
9506 C         print *,"I am in true lipid"
9507         endif
9508         else
9509 C          sstube=0.0d0
9510 C          ssgradtube=0.0d0
9511         cycle
9512         endif ! if in lipid or buffor
9513
9514 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9515        enetube(i)=enetube(i)+sstube*
9516      &(pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
9517 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9518 C       print *,rdiff,rdiff6,pep_aa_tube
9519 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9520 C now we calculate gradient
9521        fac=(-12.0d0*pep_aa_tube/rdiff6-
9522      &       6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
9523 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9524 C     &rdiff,fac
9525
9526 C now direction of gg_tube vector
9527         do j=1,3
9528         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9529         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9530         enddo
9531          gg_tube(3,i)=gg_tube(3,i)
9532      &+ssgradtube*enetube(i)/sstube/2.0d0
9533          gg_tube(3,i-1)= gg_tube(3,i-1)
9534      &+ssgradtube*enetube(i)/sstube/2.0d0
9535
9536         enddo
9537 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
9538 C        print *,gg_tube(1,0),"TU"
9539         do i=itube_start,itube_end
9540 C Lets not jump over memory as we use many times iti
9541          iti=itype(i)
9542 C lets ommit dummy atoms for now
9543          if ((iti.eq.ntyp1)
9544 C in UNRES uncomment the line below as GLY has no side-chain...
9545      &      .or.(iti.eq.10)
9546      &   ) cycle
9547           vectube(1)=c(1,i+nres)
9548           vectube(1)=mod(vectube(1),boxxsize)
9549           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
9550           vectube(2)=c(2,i+nres)
9551           vectube(2)=mod(vectube(2),boxysize)
9552           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
9553
9554       vectube(1)=vectube(1)-tubecenter(1)
9555       vectube(2)=vectube(2)-tubecenter(2)
9556 C THIS FRAGMENT MAKES TUBE FINITE
9557         positi=(mod(c(3,i+nres),boxzsize))
9558         if (positi.le.0) positi=positi+boxzsize
9559 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9560 c for each residue check if it is in lipid or lipid water border area
9561 C       respos=mod(c(3,i+nres),boxzsize)
9562        print *,positi,bordtubebot,buftubebot,bordtubetop
9563        if ((positi.gt.bordtubebot)
9564      & .and.(positi.lt.bordtubetop)) then
9565 C the energy transfer exist
9566         if (positi.lt.buftubebot) then
9567          fracinbuf=1.0d0-
9568      &     ((positi-bordtubebot)/tubebufthick)
9569 C lipbufthick is thickenes of lipid buffore
9570          sstube=sscalelip(fracinbuf)
9571          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
9572          print *,ssgradtube, sstube,tubetranene(itype(i))
9573          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9574 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9575 C     &+ssgradtube*tubetranene(itype(i))
9576 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9577 C     &+ssgradtube*tubetranene(itype(i))
9578 C         print *,"doing sccale for lower part"
9579         elseif (positi.gt.buftubetop) then
9580          fracinbuf=1.0d0-
9581      &((bordtubetop-positi)/tubebufthick)
9582          sstube=sscalelip(fracinbuf)
9583          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
9584          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9585 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9586 C     &+ssgradtube*tubetranene(itype(i))
9587 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9588 C     &+ssgradtube*tubetranene(itype(i))
9589 C          print *, "doing sscalefor top part",sslip,fracinbuf
9590         else
9591          sstube=1.0d0
9592          ssgradtube=0.0d0
9593          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9594 C         print *,"I am in true lipid"
9595         endif
9596         else
9597 C          sstube=0.0d0
9598 C          ssgradtube=0.0d0
9599         cycle
9600         endif ! if in lipid or buffor
9601 CEND OF FINITE FRAGMENT
9602 C as the tube is infinity we do not calculate the Z-vector use of Z
9603 C as chosen axis
9604       vectube(3)=0.0d0
9605 C now calculte the distance
9606        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9607 C now normalize vector
9608       vectube(1)=vectube(1)/tub_r
9609       vectube(2)=vectube(2)/tub_r
9610 C calculte rdiffrence between r and r0
9611       rdiff=tub_r-tubeR0
9612 C and its 6 power
9613       rdiff6=rdiff**6.0d0
9614 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9615        sc_aa_tube=sc_aa_tube_par(iti)
9616        sc_bb_tube=sc_bb_tube_par(iti)
9617        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
9618      &                 *sstube+enetube(i+nres)
9619 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9620 C now we calculate gradient
9621        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9622      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
9623 C now direction of gg_tube vector
9624          do j=1,3
9625           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9626           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9627          enddo
9628          gg_tube_SC(3,i)=gg_tube_SC(3,i)
9629      &+ssgradtube*enetube(i+nres)/sstube
9630          gg_tube(3,i-1)= gg_tube(3,i-1)
9631      &+ssgradtube*enetube(i+nres)/sstube
9632
9633         enddo
9634         do i=itube_start,itube_end
9635           Etube=Etube+enetube(i)+enetube(i+nres)
9636         enddo
9637 C        print *,"ETUBE", etube
9638         return
9639         end
9640 C TO DO 1) add to total energy
9641 C       2) add to gradient summation
9642 C       3) add reading parameters (AND of course oppening of PARAM file)
9643 C       4) add reading the center of tube
9644 C       5) add COMMONs
9645 C       6) add to zerograd
9646
9647
9648 C#-------------------------------------------------------------------------------
9649 C This subroutine is to mimic the histone like structure but as well can be
9650 C utilizet to nanostructures (infinit) small modification has to be used to
9651 C make it finite (z gradient at the ends has to be changes as well as the x,y
9652 C gradient has to be modified at the ends
9653 C The energy function is Kihara potential
9654 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9655 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9656 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9657 C simple Kihara potential
9658       subroutine calcnano(Etube)
9659        implicit real*8 (a-h,o-z)
9660       include 'DIMENSIONS'
9661       include 'COMMON.GEO'
9662       include 'COMMON.VAR'
9663       include 'COMMON.LOCAL'
9664       include 'COMMON.CHAIN'
9665       include 'COMMON.DERIV'
9666       include 'COMMON.INTERACT'
9667       include 'COMMON.IOUNITS'
9668       include 'COMMON.CALC'
9669       include 'COMMON.CONTROL'
9670       include 'COMMON.SPLITELE'
9671       include 'COMMON.SBRIDGE'
9672       double precision tub_r,vectube(3),enetube(maxres*2),
9673      & enecavtube(maxres*2)
9674       Etube=0.0d0
9675       do i=itube_start,itube_end
9676         enetube(i)=0.0d0
9677         enetube(i+nres)=0.0d0
9678       enddo
9679 C first we calculate the distance from tube center
9680 C first sugare-phosphate group for NARES this would be peptide group
9681 C for UNRES
9682        do i=itube_start,itube_end
9683 C lets ommit dummy atoms for now
9684        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9685 C now calculate distance from center of tube and direction vectors
9686       xmin=boxxsize
9687       ymin=boxysize
9688       zmin=boxzsize
9689
9690         do j=-1,1
9691          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9692          vectube(1)=vectube(1)+boxxsize*j
9693          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9694          vectube(2)=vectube(2)+boxysize*j
9695          vectube(3)=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
9696          vectube(3)=vectube(3)+boxzsize*j
9697
9698
9699          xminact=abs(vectube(1)-tubecenter(1))
9700          yminact=abs(vectube(2)-tubecenter(2))
9701          zminact=abs(vectube(3)-tubecenter(3))
9702
9703            if (xmin.gt.xminact) then
9704             xmin=xminact
9705             xtemp=vectube(1)
9706            endif
9707            if (ymin.gt.yminact) then
9708              ymin=yminact
9709              ytemp=vectube(2)
9710             endif
9711            if (zmin.gt.zminact) then
9712              zmin=zminact
9713              ztemp=vectube(3)
9714             endif
9715          enddo
9716       vectube(1)=xtemp
9717       vectube(2)=ytemp
9718       vectube(3)=ztemp
9719
9720       vectube(1)=vectube(1)-tubecenter(1)
9721       vectube(2)=vectube(2)-tubecenter(2)
9722       vectube(3)=vectube(3)-tubecenter(3)
9723
9724 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9725 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9726 C as the tube is infinity we do not calculate the Z-vector use of Z
9727 C as chosen axis
9728 C      vectube(3)=0.0d0
9729 C now calculte the distance
9730        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9731 C now normalize vector
9732       vectube(1)=vectube(1)/tub_r
9733       vectube(2)=vectube(2)/tub_r
9734       vectube(3)=vectube(3)/tub_r
9735 C calculte rdiffrence between r and r0
9736       rdiff=tub_r-tubeR0
9737 C and its 6 power
9738       rdiff6=rdiff**6.0d0
9739 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9740        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
9741 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9742 C       print *,rdiff,rdiff6,pep_aa_tube
9743 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9744 C now we calculate gradient
9745        fac=(-12.0d0*pep_aa_tube/rdiff6-
9746      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
9747 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9748 C     &rdiff,fac
9749          if (acavtubpep.eq.0.0d0) then
9750 C go to 667
9751          enecavtube(i)=0.0
9752          faccav=0.0
9753          else
9754          denominator=(1.0+dcavtubpep*rdiff6*rdiff6)
9755          enecavtube(i)=
9756      &   (bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)+ccavtubpep)
9757      &   /denominator
9758          enecavtube(i)=0.0
9759          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/sqrt(rdiff))
9760      &   *denominator-(bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)
9761      &   +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)
9762      &   /denominator**2.0d0
9763 C         faccav=0.0
9764 C         fac=fac+faccav
9765 C 667     continue
9766          endif
9767 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtubpep,denominator,
9768 C     &   enecavtube(i),faccav
9769 C         print *,"licz=",
9770 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9771 CX         print *,"finene=",enetube(i+nres)+enecavtube(i)
9772
9773 C now direction of gg_tube vector
9774         do j=1,3
9775         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9776         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9777         enddo
9778         enddo
9779
9780        do i=itube_start,itube_end
9781         enecavtube(i)=0.0
9782 C Lets not jump over memory as we use many times iti
9783          iti=itype(i)
9784 C lets ommit dummy atoms for now
9785          if ((iti.eq.ntyp1)
9786 C in UNRES uncomment the line below as GLY has no side-chain...
9787 C      .or.(iti.eq.10)
9788      &   ) cycle
9789       xmin=boxxsize
9790       ymin=boxysize
9791       zmin=boxzsize
9792         do j=-1,1
9793          vectube(1)=mod((c(1,i+nres)),boxxsize)
9794          vectube(1)=vectube(1)+boxxsize*j
9795          vectube(2)=mod((c(2,i+nres)),boxysize)
9796          vectube(2)=vectube(2)+boxysize*j
9797          vectube(3)=mod((c(3,i+nres)),boxzsize)
9798          vectube(3)=vectube(3)+boxzsize*j
9799
9800
9801          xminact=abs(vectube(1)-tubecenter(1))
9802          yminact=abs(vectube(2)-tubecenter(2))
9803          zminact=abs(vectube(3)-tubecenter(3))
9804
9805            if (xmin.gt.xminact) then
9806             xmin=xminact
9807             xtemp=vectube(1)
9808            endif
9809            if (ymin.gt.yminact) then
9810              ymin=yminact
9811              ytemp=vectube(2)
9812             endif
9813            if (zmin.gt.zminact) then
9814              zmin=zminact
9815              ztemp=vectube(3)
9816             endif
9817          enddo
9818       vectube(1)=xtemp
9819       vectube(2)=ytemp
9820       vectube(3)=ztemp
9821
9822 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
9823 C     &     tubecenter(2)
9824       vectube(1)=vectube(1)-tubecenter(1)
9825       vectube(2)=vectube(2)-tubecenter(2)
9826       vectube(3)=vectube(3)-tubecenter(3)
9827 C now calculte the distance
9828        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9829 C now normalize vector
9830       vectube(1)=vectube(1)/tub_r
9831       vectube(2)=vectube(2)/tub_r
9832       vectube(3)=vectube(3)/tub_r
9833
9834 C calculte rdiffrence between r and r0
9835       rdiff=tub_r-tubeR0
9836 C and its 6 power
9837       rdiff6=rdiff**6.0d0
9838 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9839        sc_aa_tube=sc_aa_tube_par(iti)
9840        sc_bb_tube=sc_bb_tube_par(iti)
9841        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
9842 C       enetube(i+nres)=0.0d0
9843 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9844 C now we calculate gradient
9845        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9846      &       6.0d0*sc_bb_tube/rdiff6/rdiff
9847 C       fac=0.0
9848 C now direction of gg_tube vector
9849 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
9850          if (acavtub(iti).eq.0.0d0) then
9851 C go to 667
9852          enecavtube(i+nres)=0.0
9853          faccav=0.0
9854          else
9855          denominator=(1.0+dcavtub(iti)*rdiff6*rdiff6)
9856          enecavtube(i+nres)=
9857      &   (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9858      &   /denominator
9859 C         enecavtube(i)=0.0
9860          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/sqrt(rdiff))
9861      &   *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)
9862      &   +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)
9863      &   /denominator**2.0d0
9864 C         faccav=0.0
9865          fac=fac+faccav
9866 C 667     continue
9867          endif
9868 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
9869 C     &   enecavtube(i),faccav
9870 C         print *,"licz=",
9871 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9872 C         print *,"finene=",enetube(i+nres)+enecavtube(i)
9873          do j=1,3
9874           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9875           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9876          enddo
9877         enddo
9878 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
9879 C        do i=itube_start,itube_end
9880 C        enecav(i)=0.0
9881 C        iti=itype(i)
9882 C        if (acavtub(iti).eq.0.0) cycle
9883
9884
9885
9886         do i=itube_start,itube_end
9887           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i)
9888      & +enecavtube(i+nres)
9889         enddo
9890 C        print *,"ETUBE", etube
9891         return
9892         end
9893 C TO DO 1) add to total energy
9894 C       2) add to gradient summation
9895 C       3) add reading parameters (AND of course oppening of PARAM file)
9896 C       4) add reading the center of tube
9897 C       5) add COMMONs
9898 C       6) add to zerograd
9899