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      &                +wtube*gg_tube_SC(j,i)
 290
 291         else
 292           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 293      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 294      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 295      &                wbond*gradb(j,i)+
 296      &                wstrain*ghpbc(j,i)+
 297      &                wcorr*fact(3)*gradcorr(j,i)+
 298      &                wel_loc*fact(2)*gel_loc(j,i)+
 299      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 300      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 301      &                wcorr5*fact(4)*gradcorr5(j,i)+
 302      &                wcorr6*fact(5)*gradcorr6(j,i)+
 303      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 304      &                wsccor*fact(2)*gsccorc(j,i)
 305      &               +wliptran*gliptranc(j,i)
 306      &                 +welec*gshieldc(j,i)
 307      &                 +welec*gshieldc_loc(j,i)
 308      &                 +wcorr*gshieldc_ec(j,i)
 309      &                 +wcorr*gshieldc_loc_ec(j,i)
 310      &                 +wturn3*gshieldc_t3(j,i)
 311      &                 +wturn3*gshieldc_loc_t3(j,i)
 312      &                 +wturn4*gshieldc_t4(j,i)
 313      &                 +wturn4*gshieldc_loc_t4(j,i)
 314      &                 +wel_loc*gshieldc_ll(j,i)
 315      &                 +wel_loc*gshieldc_loc_ll(j,i)
 316      &                +wtube*gg_tube(j,i)
 317
 318
 319           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 320      &                 +fact(1)*wscp*gradx_scp(j,i)+
 321      &                  wbond*gradbx(j,i)+
 322      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 323      &                  wsccor*fact(2)*gsccorx(j,i)
 324      &                 +wliptran*gliptranx(j,i)
 325      &                 +welec*gshieldx(j,i)
 326      &                 +wcorr*gshieldx_ec(j,i)
 327      &                 +wturn3*gshieldx_t3(j,i)
 328      &                 +wturn4*gshieldx_t4(j,i)
 329      &                 +wel_loc*gshieldx_ll(j,i)
 330      &                +wtube*gg_tube_SC(j,i)
 331
 332
 333         endif
 334         enddo
 335 #else
 336       do i=1,nct
 337         do j=1,3
 338                 if (shield_mode.eq.0) then
 339           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 340      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 341      &                wbond*gradb(j,i)+
 342      &                wcorr*fact(3)*gradcorr(j,i)+
 343      &                wel_loc*fact(2)*gel_loc(j,i)+
 344      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 345      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 346      &                wcorr5*fact(4)*gradcorr5(j,i)+
 347      &                wcorr6*fact(5)*gradcorr6(j,i)+
 348      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 349      &                wsccor*fact(2)*gsccorc(j,i)
 350      &               +wliptran*gliptranc(j,i)
 351      &                 +welec*gshieldc(j,i)
 352      &                 +welec*gshieldc_loc(j,i)
 353      &                 +wcorr*gshieldc_ec(j,i)
 354      &                 +wcorr*gshieldc_loc_ec(j,i)
 355      &                 +wturn3*gshieldc_t3(j,i)
 356      &                 +wturn3*gshieldc_loc_t3(j,i)
 357      &                 +wturn4*gshieldc_t4(j,i)
 358      &                 +wturn4*gshieldc_loc_t4(j,i)
 359      &                 +wel_loc*gshieldc_ll(j,i)
 360      &                 +wel_loc*gshieldc_loc_ll(j,i)
 361      &                +wtube*gg_tube(j,i)
 362
 363           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 364      &                  wbond*gradbx(j,i)+
 365      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 366      &                  wsccor*fact(1)*gsccorx(j,i)
 367      &                 +wliptran*gliptranx(j,i)
 368      &                 +welec*gshieldx(j,i)
 369      &                 +wcorr*gshieldx_ec(j,i)
 370      &                 +wturn3*gshieldx_t3(j,i)
 371      &                 +wturn4*gshieldx_t4(j,i)
 372      &                 +wel_loc*gshieldx_ll(j,i)
 373      &                 +wtube*gg_tube_sc(j,i)
 374
 375
 376               else
 377           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 378      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 379      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 380      &                wbond*gradb(j,i)+
 381      &                wcorr*fact(3)*gradcorr(j,i)+
 382      &                wel_loc*fact(2)*gel_loc(j,i)+
 383      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 384      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 385      &                wcorr5*fact(4)*gradcorr5(j,i)+
 386      &                wcorr6*fact(5)*gradcorr6(j,i)+
 387      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 388      &                wsccor*fact(2)*gsccorc(j,i)
 389      &               +wliptran*gliptranc(j,i)
 390      &                 +welec*gshieldc(j,i)
 391      &                 +welec*gshieldc_loc(j,i)
 392      &                 +wcorr*gshieldc_ec(j,i)
 393      &                 +wcorr*gshieldc_loc_ec(j,i)
 394      &                 +wturn3*gshieldc_t3(j,i)
 395      &                 +wturn3*gshieldc_loc_t3(j,i)
 396      &                 +wturn4*gshieldc_t4(j,i)
 397      &                 +wturn4*gshieldc_loc_t4(j,i)
 398      &                 +wel_loc*gshieldc_ll(j,i)
 399      &                 +wel_loc*gshieldc_loc_ll(j,i)
 400      &                +wtube*gg_tube(j,i)
 401
 402           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 403      &                  fact(1)*wscp*gradx_scp(j,i)+
 404      &                  wbond*gradbx(j,i)+
 405      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 406      &                  wsccor*fact(1)*gsccorx(j,i)
 407      &                 +wliptran*gliptranx(j,i)
 408      &                 +welec*gshieldx(j,i)
 409      &                 +wcorr*gshieldx_ec(j,i)
 410      &                 +wturn3*gshieldx_t3(j,i)
 411      &                 +wturn4*gshieldx_t4(j,i)
 412      &                 +wel_loc*gshieldx_ll(j,i)
 413      &                 +wtube*gg_tube_sc(j,i)
 414
 415
 416          endif
 417         enddo
 418 #endif
 419       enddo
 420
 421
 422       do i=1,nres-3
 423         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 424      &   +wcorr5*fact(4)*g_corr5_loc(i)
 425      &   +wcorr6*fact(5)*g_corr6_loc(i)
 426      &   +wturn4*fact(3)*gel_loc_turn4(i)
 427      &   +wturn3*fact(2)*gel_loc_turn3(i)
 428      &   +wturn6*fact(5)*gel_loc_turn6(i)
 429      &   +wel_loc*fact(2)*gel_loc_loc(i)
 430 c     &   +wsccor*fact(1)*gsccor_loc(i)
 431 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 432       enddo
 433       endif
 434       if (dyn_ss) call dyn_set_nss
 435       return
 436       end
 437 C------------------------------------------------------------------------
 438       subroutine enerprint(energia,fact)
 439       implicit real*8 (a-h,o-z)
 440       include 'DIMENSIONS'
 441       include 'DIMENSIONS.ZSCOPT'
 442       include 'COMMON.IOUNITS'
 443       include 'COMMON.FFIELD'
 444       include 'COMMON.SBRIDGE'
 445       double precision energia(0:max_ene),fact(6)
 446       etot=energia(0)
 447       evdw=energia(1)+fact(6)*energia(21)
 448 #ifdef SCP14
 449       evdw2=energia(2)+energia(17)
 450 #else
 451       evdw2=energia(2)
 452 #endif
 453       ees=energia(3)
 454 #ifdef SPLITELE
 455       evdw1=energia(16)
 456 #endif
 457       ecorr=energia(4)
 458       ecorr5=energia(5)
 459       ecorr6=energia(6)
 460       eel_loc=energia(7)
 461       eello_turn3=energia(8)
 462       eello_turn4=energia(9)
 463       eello_turn6=energia(10)
 464       ebe=energia(11)
 465       escloc=energia(12)
 466       etors=energia(13)
 467       etors_d=energia(14)
 468       ehpb=energia(15)
 469       esccor=energia(19)
 470       edihcnstr=energia(20)
 471       estr=energia(18)
 472       ethetacnstr=energia(24)
 473       eliptran=energia(22)
 474       Etube=energia(25)
 475 #ifdef SPLITELE
 476       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 477      &  wvdwpp,
 478      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 479      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 480      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 481      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 482      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 483      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 484      & eliptran,wliptran,etube,wtube ,etot
 485    10 format (/'Virtual-chain energies:'//
 486      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 487      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 488      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 489      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 490      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 491      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 492      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 493      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 494      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 495      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 496      & ' (SS bridges & dist. cnstr.)'/
 497      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 498      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 499      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 500      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 501      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 502      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 503      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 504      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 505      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 506      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 507      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 508      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 509      & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 510      & 'ETOT=  ',1pE16.6,' (total)')
 511 #else
 512       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 513      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 514      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 515      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 516      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 517      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 518      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etube,wtube,etot
 519    10 format (/'Virtual-chain energies:'//
 520      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 521      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 522      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 523      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 524      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 525      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 526      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 527      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 528      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 529      & ' (SS bridges & dist. cnstr.)'/
 530      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 531      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 532      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 533      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 534      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 535      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 536      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 537      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 538      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 539      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 540      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 541      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 542      & 'ETOT=  ',1pE16.6,' (total)')
 543 #endif
 544       return
 545       end
 546 C-----------------------------------------------------------------------
 547       subroutine elj(evdw,evdw_t)
 548 C
 549 C This subroutine calculates the interaction energy of nonbonded side chains
 550 C assuming the LJ potential of interaction.
 551 C
 552       implicit real*8 (a-h,o-z)
 553       include 'DIMENSIONS'
 554       include 'DIMENSIONS.ZSCOPT'
 555       include "DIMENSIONS.COMPAR"
 556       parameter (accur=1.0d-10)
 557       include 'COMMON.GEO'
 558       include 'COMMON.VAR'
 559       include 'COMMON.LOCAL'
 560       include 'COMMON.CHAIN'
 561       include 'COMMON.DERIV'
 562       include 'COMMON.INTERACT'
 563       include 'COMMON.TORSION'
 564       include 'COMMON.ENEPS'
 565       include 'COMMON.SBRIDGE'
 566       include 'COMMON.NAMES'
 567       include 'COMMON.IOUNITS'
 568       include 'COMMON.CONTACTS'
 569       dimension gg(3)
 570       integer icant
 571       external icant
 572 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 573 c ROZNICA z cluster
 574       do i=1,210
 575         do j=1,2
 576           eneps_temp(j,i)=0.0d0
 577         enddo
 578       enddo
 579 cROZNICA
 580
 581       evdw=0.0D0
 582       evdw_t=0.0d0
 583       do i=iatsc_s,iatsc_e
 584         itypi=iabs(itype(i))
 585         if (itypi.eq.ntyp1) cycle
 586         itypi1=iabs(itype(i+1))
 587         xi=c(1,nres+i)
 588         yi=c(2,nres+i)
 589         zi=c(3,nres+i)
 590 C Change 12/1/95
 591         num_conti=0
 592 C
 593 C Calculate SC interaction energy.
 594 C
 595         do iint=1,nint_gr(i)
 596 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 597 cd   &                  'iend=',iend(i,iint)
 598           do j=istart(i,iint),iend(i,iint)
 599             itypj=iabs(itype(j))
 600             if (itypj.eq.ntyp1) cycle
 601             xj=c(1,nres+j)-xi
 602             yj=c(2,nres+j)-yi
 603             zj=c(3,nres+j)-zi
 604 C Change 12/1/95 to calculate four-body interactions
 605             rij=xj*xj+yj*yj+zj*zj
 606             rrij=1.0D0/rij
 607 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 608             eps0ij=eps(itypi,itypj)
 609             fac=rrij**expon2
 610             e1=fac*fac*aa
 611             e2=fac*bb
 612             evdwij=e1+e2
 613             ij=icant(itypi,itypj)
 614 c ROZNICA z cluster
 615             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 616             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 617 c
 618
 619 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 620 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 621 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 622 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 623 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 624 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 625             if (bb.gt.0.0d0) then
 626               evdw=evdw+evdwij
 627             else
 628               evdw_t=evdw_t+evdwij
 629             endif
 630             if (calc_grad) then
 631 C
 632 C Calculate the components of the gradient in DC and X
 633 C
 634             fac=-rrij*(e1+evdwij)
 635             gg(1)=xj*fac
 636             gg(2)=yj*fac
 637             gg(3)=zj*fac
 638             do k=1,3
 639               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 640               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 641             enddo
 642             do k=i,j-1
 643               do l=1,3
 644                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 645               enddo
 646             enddo
 647             endif
 648 C
 649 C 12/1/95, revised on 5/20/97
 650 C
 651 C Calculate the contact function. The ith column of the array JCONT will
 652 C contain the numbers of atoms that make contacts with the atom I (of numbers
 653 C greater than I). The arrays FACONT and GACONT will contain the values of
 654 C the contact function and its derivative.
 655 C
 656 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 657 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 658 C Uncomment next line, if the correlation interactions are contact function only
 659             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 660               rij=dsqrt(rij)
 661               sigij=sigma(itypi,itypj)
 662               r0ij=rs0(itypi,itypj)
 663 C
 664 C Check whether the SC's are not too far to make a contact.
 665 C
 666               rcut=1.5d0*r0ij
 667               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 668 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 669 C
 670               if (fcont.gt.0.0D0) then
 671 C If the SC-SC distance if close to sigma, apply spline.
 672 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 673 cAdam &             fcont1,fprimcont1)
 674 cAdam           fcont1=1.0d0-fcont1
 675 cAdam           if (fcont1.gt.0.0d0) then
 676 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 677 cAdam             fcont=fcont*fcont1
 678 cAdam           endif
 679 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 680 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 681 cga             do k=1,3
 682 cga               gg(k)=gg(k)*eps0ij
 683 cga             enddo
 684 cga             eps0ij=-evdwij*eps0ij
 685 C Uncomment for AL's type of SC correlation interactions.
 686 cadam           eps0ij=-evdwij
 687                 num_conti=num_conti+1
 688                 jcont(num_conti,i)=j
 689                 facont(num_conti,i)=fcont*eps0ij
 690                 fprimcont=eps0ij*fprimcont/rij
 691                 fcont=expon*fcont
 692 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 693 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 694 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 695 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 696                 gacont(1,num_conti,i)=-fprimcont*xj
 697                 gacont(2,num_conti,i)=-fprimcont*yj
 698                 gacont(3,num_conti,i)=-fprimcont*zj
 699 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 700 cd              write (iout,'(2i3,3f10.5)')
 701 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 702               endif
 703             endif
 704           enddo      ! j
 705         enddo        ! iint
 706 C Change 12/1/95
 707         num_cont(i)=num_conti
 708       enddo          ! i
 709       if (calc_grad) then
 710       do i=1,nct
 711         do j=1,3
 712           gvdwc(j,i)=expon*gvdwc(j,i)
 713           gvdwx(j,i)=expon*gvdwx(j,i)
 714         enddo
 715       enddo
 716       endif
 717 C******************************************************************************
 718 C
 719 C                              N O T E !!!
 720 C
 721 C To save time, the factor of EXPON has been extracted from ALL components
 722 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 723 C use!
 724 C
 725 C******************************************************************************
 726       return
 727       end
 728 C-----------------------------------------------------------------------------
 729       subroutine eljk(evdw,evdw_t)
 730 C
 731 C This subroutine calculates the interaction energy of nonbonded side chains
 732 C assuming the LJK potential of interaction.
 733 C
 734       implicit real*8 (a-h,o-z)
 735       include 'DIMENSIONS'
 736       include 'DIMENSIONS.ZSCOPT'
 737       include "DIMENSIONS.COMPAR"
 738       include 'COMMON.GEO'
 739       include 'COMMON.VAR'
 740       include 'COMMON.LOCAL'
 741       include 'COMMON.CHAIN'
 742       include 'COMMON.DERIV'
 743       include 'COMMON.INTERACT'
 744       include 'COMMON.ENEPS'
 745       include 'COMMON.IOUNITS'
 746       include 'COMMON.NAMES'
 747       dimension gg(3)
 748       logical scheck
 749       integer icant
 750       external icant
 751 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 752       do i=1,210
 753         do j=1,2
 754           eneps_temp(j,i)=0.0d0
 755         enddo
 756       enddo
 757       evdw=0.0D0
 758       evdw_t=0.0d0
 759       do i=iatsc_s,iatsc_e
 760         itypi=iabs(itype(i))
 761         if (itypi.eq.ntyp1) cycle
 762         itypi1=iabs(itype(i+1))
 763         xi=c(1,nres+i)
 764         yi=c(2,nres+i)
 765         zi=c(3,nres+i)
 766 C
 767 C Calculate SC interaction energy.
 768 C
 769         do iint=1,nint_gr(i)
 770           do j=istart(i,iint),iend(i,iint)
 771             itypj=iabs(itype(j))
 772             if (itypj.eq.ntyp1) cycle
 773             xj=c(1,nres+j)-xi
 774             yj=c(2,nres+j)-yi
 775             zj=c(3,nres+j)-zi
 776             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 777             fac_augm=rrij**expon
 778             e_augm=augm(itypi,itypj)*fac_augm
 779             r_inv_ij=dsqrt(rrij)
 780             rij=1.0D0/r_inv_ij
 781             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 782             fac=r_shift_inv**expon
 783             e1=fac*fac*aa
 784             e2=fac*bb
 785             evdwij=e_augm+e1+e2
 786             ij=icant(itypi,itypj)
 787             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 788      &        /dabs(eps(itypi,itypj))
 789             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 790 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 791 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 792 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 793 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 794 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 795 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 796 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 797             if (bb.gt.0.0d0) then
 798               evdw=evdw+evdwij
 799             else
 800               evdw_t=evdw_t+evdwij
 801             endif
 802             if (calc_grad) then
 803 C
 804 C Calculate the components of the gradient in DC and X
 805 C
 806             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 807             gg(1)=xj*fac
 808             gg(2)=yj*fac
 809             gg(3)=zj*fac
 810             do k=1,3
 811               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 812               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 813             enddo
 814             do k=i,j-1
 815               do l=1,3
 816                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 817               enddo
 818             enddo
 819             endif
 820           enddo      ! j
 821         enddo        ! iint
 822       enddo          ! i
 823       if (calc_grad) then
 824       do i=1,nct
 825         do j=1,3
 826           gvdwc(j,i)=expon*gvdwc(j,i)
 827           gvdwx(j,i)=expon*gvdwx(j,i)
 828         enddo
 829       enddo
 830       endif
 831       return
 832       end
 833 C-----------------------------------------------------------------------------
 834       subroutine ebp(evdw,evdw_t)
 835 C
 836 C This subroutine calculates the interaction energy of nonbonded side chains
 837 C assuming the Berne-Pechukas potential of interaction.
 838 C
 839       implicit real*8 (a-h,o-z)
 840       include 'DIMENSIONS'
 841       include 'DIMENSIONS.ZSCOPT'
 842       include "DIMENSIONS.COMPAR"
 843       include 'COMMON.GEO'
 844       include 'COMMON.VAR'
 845       include 'COMMON.LOCAL'
 846       include 'COMMON.CHAIN'
 847       include 'COMMON.DERIV'
 848       include 'COMMON.NAMES'
 849       include 'COMMON.INTERACT'
 850       include 'COMMON.ENEPS'
 851       include 'COMMON.IOUNITS'
 852       include 'COMMON.CALC'
 853       common /srutu/ icall
 854 c     double precision rrsave(maxdim)
 855       logical lprn
 856       integer icant
 857       external icant
 858       do i=1,210
 859         do j=1,2
 860           eneps_temp(j,i)=0.0d0
 861         enddo
 862       enddo
 863       evdw=0.0D0
 864       evdw_t=0.0d0
 865 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 866 c     if (icall.eq.0) then
 867 c       lprn=.true.
 868 c     else
 869         lprn=.false.
 870 c     endif
 871       ind=0
 872       do i=iatsc_s,iatsc_e
 873         itypi=iabs(itype(i))
 874         if (itypi.eq.ntyp1) cycle
 875         itypi1=iabs(itype(i+1))
 876         xi=c(1,nres+i)
 877         yi=c(2,nres+i)
 878         zi=c(3,nres+i)
 879         dxi=dc_norm(1,nres+i)
 880         dyi=dc_norm(2,nres+i)
 881         dzi=dc_norm(3,nres+i)
 882         dsci_inv=vbld_inv(i+nres)
 883 C
 884 C Calculate SC interaction energy.
 885 C
 886         do iint=1,nint_gr(i)
 887           do j=istart(i,iint),iend(i,iint)
 888             ind=ind+1
 889             itypj=iabs(itype(j))
 890             if (itypj.eq.ntyp1) cycle
 891             dscj_inv=vbld_inv(j+nres)
 892             chi1=chi(itypi,itypj)
 893             chi2=chi(itypj,itypi)
 894             chi12=chi1*chi2
 895             chip1=chip(itypi)
 896             chip2=chip(itypj)
 897             chip12=chip1*chip2
 898             alf1=alp(itypi)
 899             alf2=alp(itypj)
 900             alf12=0.5D0*(alf1+alf2)
 901 C For diagnostics only!!!
 902 c           chi1=0.0D0
 903 c           chi2=0.0D0
 904 c           chi12=0.0D0
 905 c           chip1=0.0D0
 906 c           chip2=0.0D0
 907 c           chip12=0.0D0
 908 c           alf1=0.0D0
 909 c           alf2=0.0D0
 910 c           alf12=0.0D0
 911             xj=c(1,nres+j)-xi
 912             yj=c(2,nres+j)-yi
 913             zj=c(3,nres+j)-zi
 914             dxj=dc_norm(1,nres+j)
 915             dyj=dc_norm(2,nres+j)
 916             dzj=dc_norm(3,nres+j)
 917             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 918 cd          if (icall.eq.0) then
 919 cd            rrsave(ind)=rrij
 920 cd          else
 921 cd            rrij=rrsave(ind)
 922 cd          endif
 923             rij=dsqrt(rrij)
 924 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 925             call sc_angular
 926 C Calculate whole angle-dependent part of epsilon and contributions
 927 C to its derivatives
 928             fac=(rrij*sigsq)**expon2
 929             e1=fac*fac*aa
 930             e2=fac*bb
 931             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 932             eps2der=evdwij*eps3rt
 933             eps3der=evdwij*eps2rt
 934             evdwij=evdwij*eps2rt*eps3rt
 935             ij=icant(itypi,itypj)
 936             aux=eps1*eps2rt**2*eps3rt**2
 937             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 938      &        /dabs(eps(itypi,itypj))
 939             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 940             if (bb.gt.0.0d0) then
 941               evdw=evdw+evdwij
 942             else
 943               evdw_t=evdw_t+evdwij
 944             endif
 945             if (calc_grad) then
 946             if (lprn) then
 947             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 948             epsi=bb**2/aa
 949             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 950      &        restyp(itypi),i,restyp(itypj),j,
 951      &        epsi,sigm,chi1,chi2,chip1,chip2,
 952      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 953      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 954      &        evdwij
 955             endif
 956 C Calculate gradient components.
 957             e1=e1*eps1*eps2rt**2*eps3rt**2
 958             fac=-expon*(e1+evdwij)
 959             sigder=fac/sigsq
 960             fac=rrij*fac
 961 C Calculate radial part of the gradient
 962             gg(1)=xj*fac
 963             gg(2)=yj*fac
 964             gg(3)=zj*fac
 965 C Calculate the angular part of the gradient and sum add the contributions
 966 C to the appropriate components of the Cartesian gradient.
 967             call sc_grad
 968             endif
 969           enddo      ! j
 970         enddo        ! iint
 971       enddo          ! i
 972 c     stop
 973       return
 974       end
 975 C-----------------------------------------------------------------------------
 976       subroutine egb(evdw,evdw_t)
 977 C
 978 C This subroutine calculates the interaction energy of nonbonded side chains
 979 C assuming the Gay-Berne potential of interaction.
 980 C
 981       implicit real*8 (a-h,o-z)
 982       include 'DIMENSIONS'
 983       include 'DIMENSIONS.ZSCOPT'
 984       include "DIMENSIONS.COMPAR"
 985       include 'COMMON.GEO'
 986       include 'COMMON.VAR'
 987       include 'COMMON.LOCAL'
 988       include 'COMMON.CHAIN'
 989       include 'COMMON.DERIV'
 990       include 'COMMON.NAMES'
 991       include 'COMMON.INTERACT'
 992       include 'COMMON.ENEPS'
 993       include 'COMMON.IOUNITS'
 994       include 'COMMON.CALC'
 995       include 'COMMON.SBRIDGE'
 996       logical lprn
 997       common /srutu/icall
 998       integer icant,xshift,yshift,zshift
 999       external icant
1000       do i=1,210
1001         do j=1,2
1002           eneps_temp(j,i)=0.0d0
1003         enddo
1004       enddo
1005 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1006       evdw=0.0D0
1007       evdw_t=0.0d0
1008       lprn=.false.
1009 c      if (icall.gt.0) lprn=.true.
1010       ind=0
1011       do i=iatsc_s,iatsc_e
1012         itypi=iabs(itype(i))
1013         if (itypi.eq.ntyp1) cycle
1014         itypi1=iabs(itype(i+1))
1015         xi=c(1,nres+i)
1016         yi=c(2,nres+i)
1017         zi=c(3,nres+i)
1018 C returning the ith atom to box
1019           xi=mod(xi,boxxsize)
1020           if (xi.lt.0) xi=xi+boxxsize
1021           yi=mod(yi,boxysize)
1022           if (yi.lt.0) yi=yi+boxysize
1023           zi=mod(zi,boxzsize)
1024           if (zi.lt.0) zi=zi+boxzsize
1025        if ((zi.gt.bordlipbot)
1026      &.and.(zi.lt.bordliptop)) then
1027 C the energy transfer exist
1028         if (zi.lt.buflipbot) then
1029 C what fraction I am in
1030          fracinbuf=1.0d0-
1031      &        ((zi-bordlipbot)/lipbufthick)
1032 C lipbufthick is thickenes of lipid buffore
1033          sslipi=sscalelip(fracinbuf)
1034          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1035         elseif (zi.gt.bufliptop) then
1036          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1037          sslipi=sscalelip(fracinbuf)
1038          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1039         else
1040          sslipi=1.0d0
1041          ssgradlipi=0.0
1042         endif
1043        else
1044          sslipi=0.0d0
1045          ssgradlipi=0.0
1046        endif
1047
1048         dxi=dc_norm(1,nres+i)
1049         dyi=dc_norm(2,nres+i)
1050         dzi=dc_norm(3,nres+i)
1051         dsci_inv=vbld_inv(i+nres)
1052 C
1053 C Calculate SC interaction energy.
1054 C
1055         do iint=1,nint_gr(i)
1056           do j=istart(i,iint),iend(i,iint)
1057             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1058               call dyn_ssbond_ene(i,j,evdwij)
1059               evdw=evdw+evdwij
1060 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1061 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1062 C triple bond artifac removal
1063              do k=j+1,iend(i,iint)
1064 C search over all next residues
1065               if (dyn_ss_mask(k)) then
1066 C check if they are cysteins
1067 C              write(iout,*) 'k=',k
1068               call triple_ssbond_ene(i,j,k,evdwij)
1069 C call the energy function that removes the artifical triple disulfide
1070 C bond the soubroutine is located in ssMD.F
1071               evdw=evdw+evdwij
1072 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1073 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1074               endif!dyn_ss_mask(k)
1075              enddo! k
1076             ELSE
1077             ind=ind+1
1078             itypj=iabs(itype(j))
1079             if (itypj.eq.ntyp1) cycle
1080             dscj_inv=vbld_inv(j+nres)
1081             sig0ij=sigma(itypi,itypj)
1082             chi1=chi(itypi,itypj)
1083             chi2=chi(itypj,itypi)
1084             chi12=chi1*chi2
1085             chip1=chip(itypi)
1086             chip2=chip(itypj)
1087             chip12=chip1*chip2
1088             alf1=alp(itypi)
1089             alf2=alp(itypj)
1090             alf12=0.5D0*(alf1+alf2)
1091 C For diagnostics only!!!
1092 c           chi1=0.0D0
1093 c           chi2=0.0D0
1094 c           chi12=0.0D0
1095 c           chip1=0.0D0
1096 c           chip2=0.0D0
1097 c           chip12=0.0D0
1098 c           alf1=0.0D0
1099 c           alf2=0.0D0
1100 c           alf12=0.0D0
1101             xj=c(1,nres+j)
1102             yj=c(2,nres+j)
1103             zj=c(3,nres+j)
1104 C returning jth atom to box
1105           xj=mod(xj,boxxsize)
1106           if (xj.lt.0) xj=xj+boxxsize
1107           yj=mod(yj,boxysize)
1108           if (yj.lt.0) yj=yj+boxysize
1109           zj=mod(zj,boxzsize)
1110           if (zj.lt.0) zj=zj+boxzsize
1111        if ((zj.gt.bordlipbot)
1112      &.and.(zj.lt.bordliptop)) then
1113 C the energy transfer exist
1114         if (zj.lt.buflipbot) then
1115 C what fraction I am in
1116          fracinbuf=1.0d0-
1117      &        ((zj-bordlipbot)/lipbufthick)
1118 C lipbufthick is thickenes of lipid buffore
1119          sslipj=sscalelip(fracinbuf)
1120          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1121         elseif (zj.gt.bufliptop) then
1122          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1123          sslipj=sscalelip(fracinbuf)
1124          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1125         else
1126          sslipj=1.0d0
1127          ssgradlipj=0.0
1128         endif
1129        else
1130          sslipj=0.0d0
1131          ssgradlipj=0.0
1132        endif
1133       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1134      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1135       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1136      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1137 C       if (aa.ne.aa_aq(itypi,itypj)) then
1138
1139 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1140 C     & bb_aq(itypi,itypj)-bb,
1141 C     & sslipi,sslipj
1142 C         endif
1143
1144 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1145 C checking the distance
1146       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1147       xj_safe=xj
1148       yj_safe=yj
1149       zj_safe=zj
1150       subchap=0
1151 C finding the closest
1152       do xshift=-1,1
1153       do yshift=-1,1
1154       do zshift=-1,1
1155           xj=xj_safe+xshift*boxxsize
1156           yj=yj_safe+yshift*boxysize
1157           zj=zj_safe+zshift*boxzsize
1158           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1159           if(dist_temp.lt.dist_init) then
1160             dist_init=dist_temp
1161             xj_temp=xj
1162             yj_temp=yj
1163             zj_temp=zj
1164             subchap=1
1165           endif
1166        enddo
1167        enddo
1168        enddo
1169        if (subchap.eq.1) then
1170           xj=xj_temp-xi
1171           yj=yj_temp-yi
1172           zj=zj_temp-zi
1173        else
1174           xj=xj_safe-xi
1175           yj=yj_safe-yi
1176           zj=zj_safe-zi
1177        endif
1178
1179             dxj=dc_norm(1,nres+j)
1180             dyj=dc_norm(2,nres+j)
1181             dzj=dc_norm(3,nres+j)
1182 c            write (iout,*) i,j,xj,yj,zj
1183             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1184             rij=dsqrt(rrij)
1185             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1186             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1187             if (sss.le.0.0) cycle
1188 C Calculate angle-dependent terms of energy and contributions to their
1189 C derivatives.
1190
1191             call sc_angular
1192             sigsq=1.0D0/sigsq
1193             sig=sig0ij*dsqrt(sigsq)
1194             rij_shift=1.0D0/rij-sig+sig0ij
1195 C I hate to put IF's in the loops, but here don't have another choice!!!!
1196             if (rij_shift.le.0.0D0) then
1197               evdw=1.0D20
1198               return
1199             endif
1200             sigder=-sig*sigsq
1201 c---------------------------------------------------------------
1202             rij_shift=1.0D0/rij_shift
1203             fac=rij_shift**expon
1204             e1=fac*fac*aa
1205             e2=fac*bb
1206             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1207             eps2der=evdwij*eps3rt
1208             eps3der=evdwij*eps2rt
1209             evdwij=evdwij*eps2rt*eps3rt
1210             if (bb.gt.0) then
1211               evdw=evdw+evdwij*sss
1212             else
1213               evdw_t=evdw_t+evdwij*sss
1214             endif
1215             ij=icant(itypi,itypj)
1216             aux=eps1*eps2rt**2*eps3rt**2
1217             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1218      &        /dabs(eps(itypi,itypj))
1219             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1220 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1221 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1222 c     &         aux*e2/eps(itypi,itypj)
1223 c            if (lprn) then
1224             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1225             epsi=bb**2/aa
1226 C#define DEBUG
1227 #ifdef DEBUG
1228             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1229      &        restyp(itypi),i,restyp(itypj),j,
1230      &        epsi,sigm,chi1,chi2,chip1,chip2,
1231      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1232      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1233      &        evdwij
1234              write (iout,*) "partial sum", evdw, evdw_t
1235 #endif
1236 C#undef DEBUG
1237 c            endif
1238             if (calc_grad) then
1239 C Calculate gradient components.
1240             e1=e1*eps1*eps2rt**2*eps3rt**2
1241             fac=-expon*(e1+evdwij)*rij_shift
1242             sigder=fac*sigder
1243             fac=rij*fac
1244             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1245 C Calculate the radial part of the gradient
1246             gg(1)=xj*fac
1247             gg(2)=yj*fac
1248             gg(3)=zj*fac
1249 C Calculate angular part of the gradient.
1250             call sc_grad
1251             endif
1252 C            write(iout,*)  "partial sum", evdw, evdw_t
1253             ENDIF    ! dyn_ss
1254           enddo      ! j
1255         enddo        ! iint
1256       enddo          ! i
1257       return
1258       end
1259 C-----------------------------------------------------------------------------
1260       subroutine egbv(evdw,evdw_t)
1261 C
1262 C This subroutine calculates the interaction energy of nonbonded side chains
1263 C assuming the Gay-Berne-Vorobjev potential of interaction.
1264 C
1265       implicit real*8 (a-h,o-z)
1266       include 'DIMENSIONS'
1267       include 'DIMENSIONS.ZSCOPT'
1268       include "DIMENSIONS.COMPAR"
1269       include 'COMMON.GEO'
1270       include 'COMMON.VAR'
1271       include 'COMMON.LOCAL'
1272       include 'COMMON.CHAIN'
1273       include 'COMMON.DERIV'
1274       include 'COMMON.NAMES'
1275       include 'COMMON.INTERACT'
1276       include 'COMMON.ENEPS'
1277       include 'COMMON.IOUNITS'
1278       include 'COMMON.CALC'
1279       common /srutu/ icall
1280       logical lprn
1281       integer icant
1282       external icant
1283       do i=1,210
1284         do j=1,2
1285           eneps_temp(j,i)=0.0d0
1286         enddo
1287       enddo
1288       evdw=0.0D0
1289       evdw_t=0.0d0
1290 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1291       evdw=0.0D0
1292       lprn=.false.
1293 c      if (icall.gt.0) lprn=.true.
1294       ind=0
1295       do i=iatsc_s,iatsc_e
1296         itypi=iabs(itype(i))
1297         if (itypi.eq.ntyp1) cycle
1298         itypi1=iabs(itype(i+1))
1299         xi=c(1,nres+i)
1300         yi=c(2,nres+i)
1301         zi=c(3,nres+i)
1302         dxi=dc_norm(1,nres+i)
1303         dyi=dc_norm(2,nres+i)
1304         dzi=dc_norm(3,nres+i)
1305         dsci_inv=vbld_inv(i+nres)
1306 C
1307 C Calculate SC interaction energy.
1308 C
1309         do iint=1,nint_gr(i)
1310           do j=istart(i,iint),iend(i,iint)
1311             ind=ind+1
1312             itypj=iabs(itype(j))
1313             if (itypj.eq.ntyp1) cycle
1314             dscj_inv=vbld_inv(j+nres)
1315             sig0ij=sigma(itypi,itypj)
1316             r0ij=r0(itypi,itypj)
1317             chi1=chi(itypi,itypj)
1318             chi2=chi(itypj,itypi)
1319             chi12=chi1*chi2
1320             chip1=chip(itypi)
1321             chip2=chip(itypj)
1322             chip12=chip1*chip2
1323             alf1=alp(itypi)
1324             alf2=alp(itypj)
1325             alf12=0.5D0*(alf1+alf2)
1326 C For diagnostics only!!!
1327 c           chi1=0.0D0
1328 c           chi2=0.0D0
1329 c           chi12=0.0D0
1330 c           chip1=0.0D0
1331 c           chip2=0.0D0
1332 c           chip12=0.0D0
1333 c           alf1=0.0D0
1334 c           alf2=0.0D0
1335 c           alf12=0.0D0
1336             xj=c(1,nres+j)-xi
1337             yj=c(2,nres+j)-yi
1338             zj=c(3,nres+j)-zi
1339             dxj=dc_norm(1,nres+j)
1340             dyj=dc_norm(2,nres+j)
1341             dzj=dc_norm(3,nres+j)
1342             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1343             rij=dsqrt(rrij)
1344 C Calculate angle-dependent terms of energy and contributions to their
1345 C derivatives.
1346             call sc_angular
1347             sigsq=1.0D0/sigsq
1348             sig=sig0ij*dsqrt(sigsq)
1349             rij_shift=1.0D0/rij-sig+r0ij
1350 C I hate to put IF's in the loops, but here don't have another choice!!!!
1351             if (rij_shift.le.0.0D0) then
1352               evdw=1.0D20
1353               return
1354             endif
1355             sigder=-sig*sigsq
1356 c---------------------------------------------------------------
1357             rij_shift=1.0D0/rij_shift
1358             fac=rij_shift**expon
1359             e1=fac*fac*aa
1360             e2=fac*bb
1361             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1362             eps2der=evdwij*eps3rt
1363             eps3der=evdwij*eps2rt
1364             fac_augm=rrij**expon
1365             e_augm=augm(itypi,itypj)*fac_augm
1366             evdwij=evdwij*eps2rt*eps3rt
1367             if (bb.gt.0.0d0) then
1368               evdw=evdw+evdwij+e_augm
1369             else
1370               evdw_t=evdw_t+evdwij+e_augm
1371             endif
1372             ij=icant(itypi,itypj)
1373             aux=eps1*eps2rt**2*eps3rt**2
1374             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1375      &        /dabs(eps(itypi,itypj))
1376             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1377 c            eneps_temp(ij)=eneps_temp(ij)
1378 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1379 c            if (lprn) then
1380 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1381 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1382 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1383 c     &        restyp(itypi),i,restyp(itypj),j,
1384 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1385 c     &        chi1,chi2,chip1,chip2,
1386 c     &        eps1,eps2rt**2,eps3rt**2,
1387 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1388 c     &        evdwij+e_augm
1389 c            endif
1390             if (calc_grad) then
1391 C Calculate gradient components.
1392             e1=e1*eps1*eps2rt**2*eps3rt**2
1393             fac=-expon*(e1+evdwij)*rij_shift
1394             sigder=fac*sigder
1395             fac=rij*fac-2*expon*rrij*e_augm
1396 C Calculate the radial part of the gradient
1397             gg(1)=xj*fac
1398             gg(2)=yj*fac
1399             gg(3)=zj*fac
1400 C Calculate angular part of the gradient.
1401             call sc_grad
1402             endif
1403           enddo      ! j
1404         enddo        ! iint
1405       enddo          ! i
1406       return
1407       end
1408 C-----------------------------------------------------------------------------
1409       subroutine sc_angular
1410 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1411 C om12. Called by ebp, egb, and egbv.
1412       implicit none
1413       include 'COMMON.CALC'
1414       erij(1)=xj*rij
1415       erij(2)=yj*rij
1416       erij(3)=zj*rij
1417       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1418       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1419       om12=dxi*dxj+dyi*dyj+dzi*dzj
1420       chiom12=chi12*om12
1421 C Calculate eps1(om12) and its derivative in om12
1422       faceps1=1.0D0-om12*chiom12
1423       faceps1_inv=1.0D0/faceps1
1424       eps1=dsqrt(faceps1_inv)
1425 C Following variable is eps1*deps1/dom12
1426       eps1_om12=faceps1_inv*chiom12
1427 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1428 C and om12.
1429       om1om2=om1*om2
1430       chiom1=chi1*om1
1431       chiom2=chi2*om2
1432       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1433       sigsq=1.0D0-facsig*faceps1_inv
1434       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1435       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1436       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1437 C Calculate eps2 and its derivatives in om1, om2, and om12.
1438       chipom1=chip1*om1
1439       chipom2=chip2*om2
1440       chipom12=chip12*om12
1441       facp=1.0D0-om12*chipom12
1442       facp_inv=1.0D0/facp
1443       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1444 C Following variable is the square root of eps2
1445       eps2rt=1.0D0-facp1*facp_inv
1446 C Following three variables are the derivatives of the square root of eps
1447 C in om1, om2, and om12.
1448       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1449       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1450       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1451 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1452       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1453 C Calculate whole angle-dependent part of epsilon and contributions
1454 C to its derivatives
1455       return
1456       end
1457 C----------------------------------------------------------------------------
1458       subroutine sc_grad
1459       implicit real*8 (a-h,o-z)
1460       include 'DIMENSIONS'
1461       include 'DIMENSIONS.ZSCOPT'
1462       include 'COMMON.CHAIN'
1463       include 'COMMON.DERIV'
1464       include 'COMMON.CALC'
1465       double precision dcosom1(3),dcosom2(3)
1466       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1467       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1468       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1469      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1470       do k=1,3
1471         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1472         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1473       enddo
1474       do k=1,3
1475         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1476       enddo
1477       do k=1,3
1478         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1479      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1480      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1481         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1482      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1483      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1484       enddo
1485 C
1486 C Calculate the components of the gradient in DC and X
1487 C
1488       do k=i,j-1
1489         do l=1,3
1490           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1491         enddo
1492       enddo
1493       return
1494       end
1495 c------------------------------------------------------------------------------
1496       subroutine vec_and_deriv
1497       implicit real*8 (a-h,o-z)
1498       include 'DIMENSIONS'
1499       include 'DIMENSIONS.ZSCOPT'
1500       include 'COMMON.IOUNITS'
1501       include 'COMMON.GEO'
1502       include 'COMMON.VAR'
1503       include 'COMMON.LOCAL'
1504       include 'COMMON.CHAIN'
1505       include 'COMMON.VECTORS'
1506       include 'COMMON.DERIV'
1507       include 'COMMON.INTERACT'
1508       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1509 C Compute the local reference systems. For reference system (i), the
1510 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1511 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1512       do i=1,nres-1
1513 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1514           if (i.eq.nres-1) then
1515 C Case of the last full residue
1516 C Compute the Z-axis
1517             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1518             costh=dcos(pi-theta(nres))
1519             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1520             do k=1,3
1521               uz(k,i)=fac*uz(k,i)
1522             enddo
1523             if (calc_grad) then
1524 C Compute the derivatives of uz
1525             uzder(1,1,1)= 0.0d0
1526             uzder(2,1,1)=-dc_norm(3,i-1)
1527             uzder(3,1,1)= dc_norm(2,i-1)
1528             uzder(1,2,1)= dc_norm(3,i-1)
1529             uzder(2,2,1)= 0.0d0
1530             uzder(3,2,1)=-dc_norm(1,i-1)
1531             uzder(1,3,1)=-dc_norm(2,i-1)
1532             uzder(2,3,1)= dc_norm(1,i-1)
1533             uzder(3,3,1)= 0.0d0
1534             uzder(1,1,2)= 0.0d0
1535             uzder(2,1,2)= dc_norm(3,i)
1536             uzder(3,1,2)=-dc_norm(2,i)
1537             uzder(1,2,2)=-dc_norm(3,i)
1538             uzder(2,2,2)= 0.0d0
1539             uzder(3,2,2)= dc_norm(1,i)
1540             uzder(1,3,2)= dc_norm(2,i)
1541             uzder(2,3,2)=-dc_norm(1,i)
1542             uzder(3,3,2)= 0.0d0
1543             endif
1544 C Compute the Y-axis
1545             facy=fac
1546             do k=1,3
1547               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1548             enddo
1549             if (calc_grad) then
1550 C Compute the derivatives of uy
1551             do j=1,3
1552               do k=1,3
1553                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1554      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1555                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1556               enddo
1557               uyder(j,j,1)=uyder(j,j,1)-costh
1558               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1559             enddo
1560             do j=1,2
1561               do k=1,3
1562                 do l=1,3
1563                   uygrad(l,k,j,i)=uyder(l,k,j)
1564                   uzgrad(l,k,j,i)=uzder(l,k,j)
1565                 enddo
1566               enddo
1567             enddo
1568             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1569             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1570             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1571             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1572             endif
1573           else
1574 C Other residues
1575 C Compute the Z-axis
1576             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1577             costh=dcos(pi-theta(i+2))
1578             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1579             do k=1,3
1580               uz(k,i)=fac*uz(k,i)
1581             enddo
1582             if (calc_grad) then
1583 C Compute the derivatives of uz
1584             uzder(1,1,1)= 0.0d0
1585             uzder(2,1,1)=-dc_norm(3,i+1)
1586             uzder(3,1,1)= dc_norm(2,i+1)
1587             uzder(1,2,1)= dc_norm(3,i+1)
1588             uzder(2,2,1)= 0.0d0
1589             uzder(3,2,1)=-dc_norm(1,i+1)
1590             uzder(1,3,1)=-dc_norm(2,i+1)
1591             uzder(2,3,1)= dc_norm(1,i+1)
1592             uzder(3,3,1)= 0.0d0
1593             uzder(1,1,2)= 0.0d0
1594             uzder(2,1,2)= dc_norm(3,i)
1595             uzder(3,1,2)=-dc_norm(2,i)
1596             uzder(1,2,2)=-dc_norm(3,i)
1597             uzder(2,2,2)= 0.0d0
1598             uzder(3,2,2)= dc_norm(1,i)
1599             uzder(1,3,2)= dc_norm(2,i)
1600             uzder(2,3,2)=-dc_norm(1,i)
1601             uzder(3,3,2)= 0.0d0
1602             endif
1603 C Compute the Y-axis
1604             facy=fac
1605             do k=1,3
1606               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1607             enddo
1608             if (calc_grad) then
1609 C Compute the derivatives of uy
1610             do j=1,3
1611               do k=1,3
1612                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1613      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1614                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1615               enddo
1616               uyder(j,j,1)=uyder(j,j,1)-costh
1617               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1618             enddo
1619             do j=1,2
1620               do k=1,3
1621                 do l=1,3
1622                   uygrad(l,k,j,i)=uyder(l,k,j)
1623                   uzgrad(l,k,j,i)=uzder(l,k,j)
1624                 enddo
1625               enddo
1626             enddo
1627             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1628             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1629             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1630             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1631           endif
1632           endif
1633       enddo
1634       if (calc_grad) then
1635       do i=1,nres-1
1636         vbld_inv_temp(1)=vbld_inv(i+1)
1637         if (i.lt.nres-1) then
1638           vbld_inv_temp(2)=vbld_inv(i+2)
1639         else
1640           vbld_inv_temp(2)=vbld_inv(i)
1641         endif
1642         do j=1,2
1643           do k=1,3
1644             do l=1,3
1645               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1646               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1647             enddo
1648           enddo
1649         enddo
1650       enddo
1651       endif
1652       return
1653       end
1654 C-----------------------------------------------------------------------------
1655       subroutine vec_and_deriv_test
1656       implicit real*8 (a-h,o-z)
1657       include 'DIMENSIONS'
1658       include 'DIMENSIONS.ZSCOPT'
1659       include 'COMMON.IOUNITS'
1660       include 'COMMON.GEO'
1661       include 'COMMON.VAR'
1662       include 'COMMON.LOCAL'
1663       include 'COMMON.CHAIN'
1664       include 'COMMON.VECTORS'
1665       dimension uyder(3,3,2),uzder(3,3,2)
1666 C Compute the local reference systems. For reference system (i), the
1667 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1668 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1669       do i=1,nres-1
1670           if (i.eq.nres-1) then
1671 C Case of the last full residue
1672 C Compute the Z-axis
1673             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1674             costh=dcos(pi-theta(nres))
1675             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1676 c            write (iout,*) 'fac',fac,
1677 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1678             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1679             do k=1,3
1680               uz(k,i)=fac*uz(k,i)
1681             enddo
1682 C Compute the derivatives of uz
1683             uzder(1,1,1)= 0.0d0
1684             uzder(2,1,1)=-dc_norm(3,i-1)
1685             uzder(3,1,1)= dc_norm(2,i-1)
1686             uzder(1,2,1)= dc_norm(3,i-1)
1687             uzder(2,2,1)= 0.0d0
1688             uzder(3,2,1)=-dc_norm(1,i-1)
1689             uzder(1,3,1)=-dc_norm(2,i-1)
1690             uzder(2,3,1)= dc_norm(1,i-1)
1691             uzder(3,3,1)= 0.0d0
1692             uzder(1,1,2)= 0.0d0
1693             uzder(2,1,2)= dc_norm(3,i)
1694             uzder(3,1,2)=-dc_norm(2,i)
1695             uzder(1,2,2)=-dc_norm(3,i)
1696             uzder(2,2,2)= 0.0d0
1697             uzder(3,2,2)= dc_norm(1,i)
1698             uzder(1,3,2)= dc_norm(2,i)
1699             uzder(2,3,2)=-dc_norm(1,i)
1700             uzder(3,3,2)= 0.0d0
1701 C Compute the Y-axis
1702             do k=1,3
1703               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1704             enddo
1705             facy=fac
1706             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1707      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1708      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1709             do k=1,3
1710 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1711               uy(k,i)=
1712 c     &        facy*(
1713      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1714      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1715 c     &        )
1716             enddo
1717 c            write (iout,*) 'facy',facy,
1718 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1719             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1720             do k=1,3
1721               uy(k,i)=facy*uy(k,i)
1722             enddo
1723 C Compute the derivatives of uy
1724             do j=1,3
1725               do k=1,3
1726                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1727      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1728                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1729               enddo
1730 c              uyder(j,j,1)=uyder(j,j,1)-costh
1731 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1732               uyder(j,j,1)=uyder(j,j,1)
1733      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1734               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1735      &          +uyder(j,j,2)
1736             enddo
1737             do j=1,2
1738               do k=1,3
1739                 do l=1,3
1740                   uygrad(l,k,j,i)=uyder(l,k,j)
1741                   uzgrad(l,k,j,i)=uzder(l,k,j)
1742                 enddo
1743               enddo
1744             enddo
1745             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1746             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1747             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1748             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1749           else
1750 C Other residues
1751 C Compute the Z-axis
1752             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1753             costh=dcos(pi-theta(i+2))
1754             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1755             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1756             do k=1,3
1757               uz(k,i)=fac*uz(k,i)
1758             enddo
1759 C Compute the derivatives of uz
1760             uzder(1,1,1)= 0.0d0
1761             uzder(2,1,1)=-dc_norm(3,i+1)
1762             uzder(3,1,1)= dc_norm(2,i+1)
1763             uzder(1,2,1)= dc_norm(3,i+1)
1764             uzder(2,2,1)= 0.0d0
1765             uzder(3,2,1)=-dc_norm(1,i+1)
1766             uzder(1,3,1)=-dc_norm(2,i+1)
1767             uzder(2,3,1)= dc_norm(1,i+1)
1768             uzder(3,3,1)= 0.0d0
1769             uzder(1,1,2)= 0.0d0
1770             uzder(2,1,2)= dc_norm(3,i)
1771             uzder(3,1,2)=-dc_norm(2,i)
1772             uzder(1,2,2)=-dc_norm(3,i)
1773             uzder(2,2,2)= 0.0d0
1774             uzder(3,2,2)= dc_norm(1,i)
1775             uzder(1,3,2)= dc_norm(2,i)
1776             uzder(2,3,2)=-dc_norm(1,i)
1777             uzder(3,3,2)= 0.0d0
1778 C Compute the Y-axis
1779             facy=fac
1780             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1781      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1782      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1783             do k=1,3
1784 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1785               uy(k,i)=
1786 c     &        facy*(
1787      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1788      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1789 c     &        )
1790             enddo
1791 c            write (iout,*) 'facy',facy,
1792 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1793             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1794             do k=1,3
1795               uy(k,i)=facy*uy(k,i)
1796             enddo
1797 C Compute the derivatives of uy
1798             do j=1,3
1799               do k=1,3
1800                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1801      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1802                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1803               enddo
1804 c              uyder(j,j,1)=uyder(j,j,1)-costh
1805 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1806               uyder(j,j,1)=uyder(j,j,1)
1807      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1808               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1809      &          +uyder(j,j,2)
1810             enddo
1811             do j=1,2
1812               do k=1,3
1813                 do l=1,3
1814                   uygrad(l,k,j,i)=uyder(l,k,j)
1815                   uzgrad(l,k,j,i)=uzder(l,k,j)
1816                 enddo
1817               enddo
1818             enddo
1819             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1820             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1821             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1822             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1823           endif
1824       enddo
1825       do i=1,nres-1
1826         do j=1,2
1827           do k=1,3
1828             do l=1,3
1829               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1830               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1831             enddo
1832           enddo
1833         enddo
1834       enddo
1835       return
1836       end
1837 C-----------------------------------------------------------------------------
1838       subroutine check_vecgrad
1839       implicit real*8 (a-h,o-z)
1840       include 'DIMENSIONS'
1841       include 'DIMENSIONS.ZSCOPT'
1842       include 'COMMON.IOUNITS'
1843       include 'COMMON.GEO'
1844       include 'COMMON.VAR'
1845       include 'COMMON.LOCAL'
1846       include 'COMMON.CHAIN'
1847       include 'COMMON.VECTORS'
1848       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1849       dimension uyt(3,maxres),uzt(3,maxres)
1850       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1851       double precision delta /1.0d-7/
1852       call vec_and_deriv
1853 cd      do i=1,nres
1854 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1855 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1856 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1857 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1858 cd     &     (dc_norm(if90,i),if90=1,3)
1859 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1860 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1861 cd          write(iout,'(a)')
1862 cd      enddo
1863       do i=1,nres
1864         do j=1,2
1865           do k=1,3
1866             do l=1,3
1867               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1868               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1869             enddo
1870           enddo
1871         enddo
1872       enddo
1873       call vec_and_deriv
1874       do i=1,nres
1875         do j=1,3
1876           uyt(j,i)=uy(j,i)
1877           uzt(j,i)=uz(j,i)
1878         enddo
1879       enddo
1880       do i=1,nres
1881 cd        write (iout,*) 'i=',i
1882         do k=1,3
1883           erij(k)=dc_norm(k,i)
1884         enddo
1885         do j=1,3
1886           do k=1,3
1887             dc_norm(k,i)=erij(k)
1888           enddo
1889           dc_norm(j,i)=dc_norm(j,i)+delta
1890 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1891 c          do k=1,3
1892 c            dc_norm(k,i)=dc_norm(k,i)/fac
1893 c          enddo
1894 c          write (iout,*) (dc_norm(k,i),k=1,3)
1895 c          write (iout,*) (erij(k),k=1,3)
1896           call vec_and_deriv
1897           do k=1,3
1898             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1899             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1900             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1901             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1902           enddo
1903 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1904 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1905 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1906         enddo
1907         do k=1,3
1908           dc_norm(k,i)=erij(k)
1909         enddo
1910 cd        do k=1,3
1911 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1912 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1913 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1914 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1915 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1916 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1917 cd          write (iout,'(a)')
1918 cd        enddo
1919       enddo
1920       return
1921       end
1922 C--------------------------------------------------------------------------
1923       subroutine set_matrices
1924       implicit real*8 (a-h,o-z)
1925       include 'DIMENSIONS'
1926       include 'DIMENSIONS.ZSCOPT'
1927       include 'COMMON.IOUNITS'
1928       include 'COMMON.GEO'
1929       include 'COMMON.VAR'
1930       include 'COMMON.LOCAL'
1931       include 'COMMON.CHAIN'
1932       include 'COMMON.DERIV'
1933       include 'COMMON.INTERACT'
1934       include 'COMMON.CONTACTS'
1935       include 'COMMON.TORSION'
1936       include 'COMMON.VECTORS'
1937       include 'COMMON.FFIELD'
1938       double precision auxvec(2),auxmat(2,2)
1939 C
1940 C Compute the virtual-bond-torsional-angle dependent quantities needed
1941 C to calculate the el-loc multibody terms of various order.
1942 C
1943       do i=3,nres+1
1944         if (i .lt. nres+1) then
1945           sin1=dsin(phi(i))
1946           cos1=dcos(phi(i))
1947           sintab(i-2)=sin1
1948           costab(i-2)=cos1
1949           obrot(1,i-2)=cos1
1950           obrot(2,i-2)=sin1
1951           sin2=dsin(2*phi(i))
1952           cos2=dcos(2*phi(i))
1953           sintab2(i-2)=sin2
1954           costab2(i-2)=cos2
1955           obrot2(1,i-2)=cos2
1956           obrot2(2,i-2)=sin2
1957           Ug(1,1,i-2)=-cos1
1958           Ug(1,2,i-2)=-sin1
1959           Ug(2,1,i-2)=-sin1
1960           Ug(2,2,i-2)= cos1
1961           Ug2(1,1,i-2)=-cos2
1962           Ug2(1,2,i-2)=-sin2
1963           Ug2(2,1,i-2)=-sin2
1964           Ug2(2,2,i-2)= cos2
1965         else
1966           costab(i-2)=1.0d0
1967           sintab(i-2)=0.0d0
1968           obrot(1,i-2)=1.0d0
1969           obrot(2,i-2)=0.0d0
1970           obrot2(1,i-2)=0.0d0
1971           obrot2(2,i-2)=0.0d0
1972           Ug(1,1,i-2)=1.0d0
1973           Ug(1,2,i-2)=0.0d0
1974           Ug(2,1,i-2)=0.0d0
1975           Ug(2,2,i-2)=1.0d0
1976           Ug2(1,1,i-2)=0.0d0
1977           Ug2(1,2,i-2)=0.0d0
1978           Ug2(2,1,i-2)=0.0d0
1979           Ug2(2,2,i-2)=0.0d0
1980         endif
1981         if (i .gt. 3 .and. i .lt. nres+1) then
1982           obrot_der(1,i-2)=-sin1
1983           obrot_der(2,i-2)= cos1
1984           Ugder(1,1,i-2)= sin1
1985           Ugder(1,2,i-2)=-cos1
1986           Ugder(2,1,i-2)=-cos1
1987           Ugder(2,2,i-2)=-sin1
1988           dwacos2=cos2+cos2
1989           dwasin2=sin2+sin2
1990           obrot2_der(1,i-2)=-dwasin2
1991           obrot2_der(2,i-2)= dwacos2
1992           Ug2der(1,1,i-2)= dwasin2
1993           Ug2der(1,2,i-2)=-dwacos2
1994           Ug2der(2,1,i-2)=-dwacos2
1995           Ug2der(2,2,i-2)=-dwasin2
1996         else
1997           obrot_der(1,i-2)=0.0d0
1998           obrot_der(2,i-2)=0.0d0
1999           Ugder(1,1,i-2)=0.0d0
2000           Ugder(1,2,i-2)=0.0d0
2001           Ugder(2,1,i-2)=0.0d0
2002           Ugder(2,2,i-2)=0.0d0
2003           obrot2_der(1,i-2)=0.0d0
2004           obrot2_der(2,i-2)=0.0d0
2005           Ug2der(1,1,i-2)=0.0d0
2006           Ug2der(1,2,i-2)=0.0d0
2007           Ug2der(2,1,i-2)=0.0d0
2008           Ug2der(2,2,i-2)=0.0d0
2009         endif
2010         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2011           if (itype(i-2).le.ntyp) then
2012             iti = itortyp(itype(i-2))
2013           else
2014             iti=ntortyp+1
2015           endif
2016         else
2017           iti=ntortyp+1
2018         endif
2019         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2020           if (itype(i-1).le.ntyp) then
2021             iti1 = itortyp(itype(i-1))
2022           else
2023             iti1=ntortyp+1
2024           endif
2025         else
2026           iti1=ntortyp+1
2027         endif
2028 cd        write (iout,*) '*******i',i,' iti1',iti
2029 cd        write (iout,*) 'b1',b1(:,iti)
2030 cd        write (iout,*) 'b2',b2(:,iti)
2031 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2032 c        print *,"itilde1 i iti iti1",i,iti,iti1
2033         if (i .gt. iatel_s+2) then
2034           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2035           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2036           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2037           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2038           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2039           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2040           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2041         else
2042           do k=1,2
2043             Ub2(k,i-2)=0.0d0
2044             Ctobr(k,i-2)=0.0d0
2045             Dtobr2(k,i-2)=0.0d0
2046             do l=1,2
2047               EUg(l,k,i-2)=0.0d0
2048               CUg(l,k,i-2)=0.0d0
2049               DUg(l,k,i-2)=0.0d0
2050               DtUg2(l,k,i-2)=0.0d0
2051             enddo
2052           enddo
2053         endif
2054 c        print *,"itilde2 i iti iti1",i,iti,iti1
2055         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2056         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2057         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2058         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2059         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2060         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2061         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2062 c        print *,"itilde3 i iti iti1",i,iti,iti1
2063         do k=1,2
2064           muder(k,i-2)=Ub2der(k,i-2)
2065         enddo
2066         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2067           if (itype(i-1).le.ntyp) then
2068             iti1 = itortyp(itype(i-1))
2069           else
2070             iti1=ntortyp+1
2071           endif
2072         else
2073           iti1=ntortyp+1
2074         endif
2075         do k=1,2
2076           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2077         enddo
2078 C        write (iout,*) 'mumu',i,b1(1,iti),Ub2(1,i-2)
2079
2080 C Vectors and matrices dependent on a single virtual-bond dihedral.
2081         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2082         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2083         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2084         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2085         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2086         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2087         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2088         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2089         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2090 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2091 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2092       enddo
2093 C Matrices dependent on two consecutive virtual-bond dihedrals.
2094 C The order of matrices is from left to right.
2095       do i=2,nres-1
2096         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2097         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2098         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2099         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2100         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2101         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2102         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2103         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2104       enddo
2105 cd      do i=1,nres
2106 cd        iti = itortyp(itype(i))
2107 cd        write (iout,*) i
2108 cd        do j=1,2
2109 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2110 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2111 cd        enddo
2112 cd      enddo
2113       return
2114       end
2115 C--------------------------------------------------------------------------
2116       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2117 C
2118 C This subroutine calculates the average interaction energy and its gradient
2119 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2120 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2121 C The potential depends both on the distance of peptide-group centers and on
2122 C the orientation of the CA-CA virtual bonds.
2123 C
2124       implicit real*8 (a-h,o-z)
2125       include 'DIMENSIONS'
2126       include 'DIMENSIONS.ZSCOPT'
2127       include 'COMMON.CONTROL'
2128       include 'COMMON.IOUNITS'
2129       include 'COMMON.GEO'
2130       include 'COMMON.VAR'
2131       include 'COMMON.LOCAL'
2132       include 'COMMON.CHAIN'
2133       include 'COMMON.DERIV'
2134       include 'COMMON.INTERACT'
2135       include 'COMMON.CONTACTS'
2136       include 'COMMON.TORSION'
2137       include 'COMMON.VECTORS'
2138       include 'COMMON.FFIELD'
2139       include 'COMMON.SHIELD'
2140       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2141      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2142       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2143      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2144       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2145 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2146       double precision scal_el /0.5d0/
2147 C 12/13/98
2148 C 13-go grudnia roku pamietnego...
2149       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2150      &                   0.0d0,1.0d0,0.0d0,
2151      &                   0.0d0,0.0d0,1.0d0/
2152 cd      write(iout,*) 'In EELEC'
2153 cd      do i=1,nloctyp
2154 cd        write(iout,*) 'Type',i
2155 cd        write(iout,*) 'B1',B1(:,i)
2156 cd        write(iout,*) 'B2',B2(:,i)
2157 cd        write(iout,*) 'CC',CC(:,:,i)
2158 cd        write(iout,*) 'DD',DD(:,:,i)
2159 cd        write(iout,*) 'EE',EE(:,:,i)
2160 cd      enddo
2161 cd      call check_vecgrad
2162 cd      stop
2163       if (icheckgrad.eq.1) then
2164         do i=1,nres-1
2165           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2166           do k=1,3
2167             dc_norm(k,i)=dc(k,i)*fac
2168           enddo
2169 c          write (iout,*) 'i',i,' fac',fac
2170         enddo
2171       endif
2172       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2173      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2174      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2175 cd      if (wel_loc.gt.0.0d0) then
2176         if (icheckgrad.eq.1) then
2177         call vec_and_deriv_test
2178         else
2179         call vec_and_deriv
2180         endif
2181         call set_matrices
2182       endif
2183 cd      do i=1,nres-1
2184 cd        write (iout,*) 'i=',i
2185 cd        do k=1,3
2186 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2187 cd        enddo
2188 cd        do k=1,3
2189 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2190 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2191 cd        enddo
2192 cd      enddo
2193       num_conti_hb=0
2194       ees=0.0D0
2195       evdw1=0.0D0
2196       eel_loc=0.0d0
2197       eello_turn3=0.0d0
2198       eello_turn4=0.0d0
2199       ind=0
2200       do i=1,nres
2201         num_cont_hb(i)=0
2202       enddo
2203 C      print '(a)','Enter EELEC'
2204 C      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2205       do i=1,nres
2206         gel_loc_loc(i)=0.0d0
2207         gcorr_loc(i)=0.0d0
2208       enddo
2209       do i=iatel_s,iatel_e
2210 C          if (i.eq.1) then
2211            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2212 C     &  .or. itype(i+2).eq.ntyp1) cycle
2213 C          else
2214 C        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2215 C     &  .or. itype(i+2).eq.ntyp1
2216 C     &  .or. itype(i-1).eq.ntyp1
2217      &) cycle
2218 C         endif
2219         if (itel(i).eq.0) goto 1215
2220         dxi=dc(1,i)
2221         dyi=dc(2,i)
2222         dzi=dc(3,i)
2223         dx_normi=dc_norm(1,i)
2224         dy_normi=dc_norm(2,i)
2225         dz_normi=dc_norm(3,i)
2226         xmedi=c(1,i)+0.5d0*dxi
2227         ymedi=c(2,i)+0.5d0*dyi
2228         zmedi=c(3,i)+0.5d0*dzi
2229           xmedi=mod(xmedi,boxxsize)
2230           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2231           ymedi=mod(ymedi,boxysize)
2232           if (ymedi.lt.0) ymedi=ymedi+boxysize
2233           zmedi=mod(zmedi,boxzsize)
2234           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2235           zmedi2=mod(zmedi,boxzsize)
2236           if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
2237        if ((zmedi2.gt.bordlipbot)
2238      &.and.(zmedi2.lt.bordliptop)) then
2239 C the energy transfer exist
2240         if (zmedi2.lt.buflipbot) then
2241 C what fraction I am in
2242          fracinbuf=1.0d0-
2243      &        ((zmedi2-bordlipbot)/lipbufthick)
2244 C lipbufthick is thickenes of lipid buffore
2245          sslipi=sscalelip(fracinbuf)
2246          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2247         elseif (zmedi2.gt.bufliptop) then
2248          fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
2249          sslipi=sscalelip(fracinbuf)
2250          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2251         else
2252          sslipi=1.0d0
2253          ssgradlipi=0.0d0
2254         endif
2255        else
2256          sslipi=0.0d0
2257          ssgradlipi=0.0d0
2258        endif
2259
2260         num_conti=0
2261 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2262         do j=ielstart(i),ielend(i)
2263           if (j.lt.1) cycle
2264 C           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2265 C     & .or.itype(j+2).eq.ntyp1
2266 C     &) cycle
2267 C          else
2268           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2269 C     & .or.itype(j+2).eq.ntyp1
2270 C     & .or.itype(j-1).eq.ntyp1
2271      &) cycle
2272 C         endif
2273 C
2274 C) cycle
2275           if (itel(j).eq.0) goto 1216
2276           ind=ind+1
2277           iteli=itel(i)
2278           itelj=itel(j)
2279           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2280           aaa=app(iteli,itelj)
2281           bbb=bpp(iteli,itelj)
2282 C Diagnostics only!!!
2283 c         aaa=0.0D0
2284 c         bbb=0.0D0
2285 c         ael6i=0.0D0
2286 c         ael3i=0.0D0
2287 C End diagnostics
2288           ael6i=ael6(iteli,itelj)
2289           ael3i=ael3(iteli,itelj)
2290           dxj=dc(1,j)
2291           dyj=dc(2,j)
2292           dzj=dc(3,j)
2293           dx_normj=dc_norm(1,j)
2294           dy_normj=dc_norm(2,j)
2295           dz_normj=dc_norm(3,j)
2296           xj=c(1,j)+0.5D0*dxj
2297           yj=c(2,j)+0.5D0*dyj
2298           zj=c(3,j)+0.5D0*dzj
2299          xj=mod(xj,boxxsize)
2300           if (xj.lt.0) xj=xj+boxxsize
2301           yj=mod(yj,boxysize)
2302           if (yj.lt.0) yj=yj+boxysize
2303           zj=mod(zj,boxzsize)
2304           if (zj.lt.0) zj=zj+boxzsize
2305        if ((zj.gt.bordlipbot)
2306      &.and.(zj.lt.bordliptop)) then
2307 C the energy transfer exist
2308         if (zj.lt.buflipbot) then
2309 C what fraction I am in
2310          fracinbuf=1.0d0-
2311      &        ((zj-bordlipbot)/lipbufthick)
2312 C lipbufthick is thickenes of lipid buffore
2313          sslipj=sscalelip(fracinbuf)
2314          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2315         elseif (zj.gt.bufliptop) then
2316          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2317          sslipj=sscalelip(fracinbuf)
2318          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2319         else
2320          sslipj=1.0d0
2321          ssgradlipj=0.0
2322         endif
2323        else
2324          sslipj=0.0d0
2325          ssgradlipj=0.0
2326        endif
2327       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2328       xj_safe=xj
2329       yj_safe=yj
2330       zj_safe=zj
2331       isubchap=0
2332       do xshift=-1,1
2333       do yshift=-1,1
2334       do zshift=-1,1
2335           xj=xj_safe+xshift*boxxsize
2336           yj=yj_safe+yshift*boxysize
2337           zj=zj_safe+zshift*boxzsize
2338           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2339           if(dist_temp.lt.dist_init) then
2340             dist_init=dist_temp
2341             xj_temp=xj
2342             yj_temp=yj
2343             zj_temp=zj
2344             isubchap=1
2345           endif
2346        enddo
2347        enddo
2348        enddo
2349        if (isubchap.eq.1) then
2350           xj=xj_temp-xmedi
2351           yj=yj_temp-ymedi
2352           zj=zj_temp-zmedi
2353        else
2354           xj=xj_safe-xmedi
2355           yj=yj_safe-ymedi
2356           zj=zj_safe-zmedi
2357        endif
2358           rij=xj*xj+yj*yj+zj*zj
2359             sss=sscale(sqrt(rij))
2360             sssgrad=sscagrad(sqrt(rij))
2361           rrmij=1.0D0/rij
2362           rij=dsqrt(rij)
2363           rmij=1.0D0/rij
2364           r3ij=rrmij*rmij
2365           r6ij=r3ij*r3ij
2366           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2367           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2368           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2369           fac=cosa-3.0D0*cosb*cosg
2370           ev1=aaa*r6ij*r6ij
2371 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2372           if (j.eq.i+2) ev1=scal_el*ev1
2373           ev2=bbb*r6ij
2374           fac3=ael6i*r6ij
2375           fac4=ael3i*r3ij
2376           evdwij=ev1+ev2
2377           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2378           el2=fac4*fac
2379           eesij=el1+el2
2380 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2381 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2382           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2383           if (shield_mode.gt.0) then
2384 C#define DEBUG
2385 #ifdef DEBUG
2386           write(iout,*) "ees_compon",i,j,el1,el2,
2387      &    fac_shield(i),fac_shield(j)
2388 #endif
2389 C#undef DEBUG
2390 C          fac_shield(i)=0.4
2391 C          fac_shield(j)=0.6
2392           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2393           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2394           eesij=(el1+el2)
2395           ees=ees+eesij
2396           else
2397           fac_shield(i)=1.0
2398           fac_shield(j)=1.0
2399           eesij=(el1+el2)
2400           ees=ees+eesij
2401           endif
2402           evdw1=evdw1+evdwij*sss
2403 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2404 c     &'evdw1',i,j,evdwij
2405 c     &,iteli,itelj,aaa,evdw1
2406
2407 C              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2408 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2409 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2410 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2411 c     &      xmedi,ymedi,zmedi,xj,yj,zj
2412 C
2413 C Calculate contributions to the Cartesian gradient.
2414 C
2415 #ifdef SPLITELE
2416           facvdw=-6*rrmij*(ev1+evdwij)*sss
2417           facel=-3*rrmij*(el1+eesij)
2418           fac1=fac
2419           erij(1)=xj*rmij
2420           erij(2)=yj*rmij
2421           erij(3)=zj*rmij
2422           if (calc_grad) then
2423 *
2424 * Radial derivatives. First process both termini of the fragment (i,j)
2425 *
2426           ggg(1)=facel*xj
2427           ggg(2)=facel*yj
2428           ggg(3)=facel*zj
2429           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2430      &  (shield_mode.gt.0)) then
2431 C          print *,i,j
2432           do ilist=1,ishield_list(i)
2433            iresshield=shield_list(ilist,i)
2434            do k=1,3
2435            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2436      &      *2.0
2437            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2438      &              rlocshield
2439      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2440             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2441 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2442 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2443 C             if (iresshield.gt.i) then
2444 C               do ishi=i+1,iresshield-1
2445 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2446 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2447 C
2448 C              enddo
2449 C             else
2450 C               do ishi=iresshield,i
2451 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2452 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2453 C
2454 C               enddo
2455 C              endif
2456            enddo
2457           enddo
2458           do ilist=1,ishield_list(j)
2459            iresshield=shield_list(ilist,j)
2460            do k=1,3
2461            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2462      &     *2.0
2463            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2464      &              rlocshield
2465      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2466            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2467            enddo
2468           enddo
2469
2470           do k=1,3
2471             gshieldc(k,i)=gshieldc(k,i)+
2472      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2473             gshieldc(k,j)=gshieldc(k,j)+
2474      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2475             gshieldc(k,i-1)=gshieldc(k,i-1)+
2476      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2477             gshieldc(k,j-1)=gshieldc(k,j-1)+
2478      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2479
2480            enddo
2481            endif
2482
2483           do k=1,3
2484             ghalf=0.5D0*ggg(k)
2485             gelc(k,i)=gelc(k,i)+ghalf
2486             gelc(k,j)=gelc(k,j)+ghalf
2487           enddo
2488 *
2489 * Loop over residues i+1 thru j-1.
2490 *
2491           do k=i+1,j-1
2492             do l=1,3
2493               gelc(l,k)=gelc(l,k)+ggg(l)
2494             enddo
2495           enddo
2496 C          ggg(1)=facvdw*xj
2497 C          ggg(2)=facvdw*yj
2498 C          ggg(3)=facvdw*zj
2499           if (sss.gt.0.0) then
2500           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2501           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2502           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2503           else
2504           ggg(1)=0.0
2505           ggg(2)=0.0
2506           ggg(3)=0.0
2507           endif
2508           do k=1,3
2509             ghalf=0.5D0*ggg(k)
2510             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2511             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2512           enddo
2513 *
2514 * Loop over residues i+1 thru j-1.
2515 *
2516           do k=i+1,j-1
2517             do l=1,3
2518               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2519             enddo
2520           enddo
2521 #else
2522           facvdw=(ev1+evdwij)*sss
2523           facel=el1+eesij
2524           fac1=fac
2525           fac=-3*rrmij*(facvdw+facvdw+facel)
2526           erij(1)=xj*rmij
2527           erij(2)=yj*rmij
2528           erij(3)=zj*rmij
2529           if (calc_grad) then
2530 *
2531 * Radial derivatives. First process both termini of the fragment (i,j)
2532 *
2533           ggg(1)=fac*xj
2534           ggg(2)=fac*yj
2535           ggg(3)=fac*zj
2536           do k=1,3
2537             ghalf=0.5D0*ggg(k)
2538             gelc(k,i)=gelc(k,i)+ghalf
2539             gelc(k,j)=gelc(k,j)+ghalf
2540           enddo
2541 *
2542 * Loop over residues i+1 thru j-1.
2543 *
2544           do k=i+1,j-1
2545             do l=1,3
2546               gelc(l,k)=gelc(l,k)+ggg(l)
2547             enddo
2548           enddo
2549 #endif
2550 *
2551 * Angular part
2552 *
2553           ecosa=2.0D0*fac3*fac1+fac4
2554           fac4=-3.0D0*fac4
2555           fac3=-6.0D0*fac3
2556           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2557           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2558           do k=1,3
2559             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2560             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2561           enddo
2562 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2563 cd   &          (dcosg(k),k=1,3)
2564           do k=1,3
2565             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2566      &      *fac_shield(i)**2*fac_shield(j)**2
2567           enddo
2568           do k=1,3
2569             ghalf=0.5D0*ggg(k)
2570             gelc(k,i)=gelc(k,i)+ghalf
2571      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2572      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2573      &           *fac_shield(i)**2*fac_shield(j)**2
2574
2575             gelc(k,j)=gelc(k,j)+ghalf
2576      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2577      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2578      &           *fac_shield(i)**2*fac_shield(j)**2
2579           enddo
2580           do k=i+1,j-1
2581             do l=1,3
2582               gelc(l,k)=gelc(l,k)+ggg(l)
2583             enddo
2584           enddo
2585           endif
2586
2587           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2588      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2589      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2590 C
2591 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2592 C   energy of a peptide unit is assumed in the form of a second-order
2593 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2594 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2595 C   are computed for EVERY pair of non-contiguous peptide groups.
2596 C
2597           if (j.lt.nres-1) then
2598             j1=j+1
2599             j2=j-1
2600           else
2601             j1=j-1
2602             j2=j-2
2603           endif
2604           kkk=0
2605           do k=1,2
2606             do l=1,2
2607               kkk=kkk+1
2608               muij(kkk)=mu(k,i)*mu(l,j)
2609             enddo
2610           enddo
2611 cd         write (iout,*) 'EELEC: i',i,' j',j
2612 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2613 cd          write(iout,*) 'muij',muij
2614           ury=scalar(uy(1,i),erij)
2615           urz=scalar(uz(1,i),erij)
2616           vry=scalar(uy(1,j),erij)
2617           vrz=scalar(uz(1,j),erij)
2618           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2619           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2620           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2621           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2622 C For diagnostics only
2623 cd          a22=1.0d0
2624 cd          a23=1.0d0
2625 cd          a32=1.0d0
2626 cd          a33=1.0d0
2627           fac=dsqrt(-ael6i)*r3ij
2628 cd          write (2,*) 'fac=',fac
2629 C For diagnostics only
2630 cd          fac=1.0d0
2631           a22=a22*fac
2632           a23=a23*fac
2633           a32=a32*fac
2634           a33=a33*fac
2635 cd          write (iout,'(4i5,4f10.5)')
2636 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2637 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2638 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2639 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2640 cd          write (iout,'(4f10.5)')
2641 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2642 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2643 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2644 cd           write (iout,'(2i3,9f10.5/)') i,j,
2645 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2646           if (calc_grad) then
2647 C Derivatives of the elements of A in virtual-bond vectors
2648           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2649 cd          do k=1,3
2650 cd            do l=1,3
2651 cd              erder(k,l)=0.0d0
2652 cd            enddo
2653 cd          enddo
2654           do k=1,3
2655             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2656             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2657             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2658             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2659             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2660             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2661             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2662             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2663             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2664             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2665             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2666             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2667           enddo
2668 cd          do k=1,3
2669 cd            do l=1,3
2670 cd              uryg(k,l)=0.0d0
2671 cd              urzg(k,l)=0.0d0
2672 cd              vryg(k,l)=0.0d0
2673 cd              vrzg(k,l)=0.0d0
2674 cd            enddo
2675 cd          enddo
2676 C Compute radial contributions to the gradient
2677           facr=-3.0d0*rrmij
2678           a22der=a22*facr
2679           a23der=a23*facr
2680           a32der=a32*facr
2681           a33der=a33*facr
2682 cd          a22der=0.0d0
2683 cd          a23der=0.0d0
2684 cd          a32der=0.0d0
2685 cd          a33der=0.0d0
2686           agg(1,1)=a22der*xj
2687           agg(2,1)=a22der*yj
2688           agg(3,1)=a22der*zj
2689           agg(1,2)=a23der*xj
2690           agg(2,2)=a23der*yj
2691           agg(3,2)=a23der*zj
2692           agg(1,3)=a32der*xj
2693           agg(2,3)=a32der*yj
2694           agg(3,3)=a32der*zj
2695           agg(1,4)=a33der*xj
2696           agg(2,4)=a33der*yj
2697           agg(3,4)=a33der*zj
2698 C Add the contributions coming from er
2699           fac3=-3.0d0*fac
2700           do k=1,3
2701             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2702             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2703             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2704             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2705           enddo
2706           do k=1,3
2707 C Derivatives in DC(i)
2708             ghalf1=0.5d0*agg(k,1)
2709             ghalf2=0.5d0*agg(k,2)
2710             ghalf3=0.5d0*agg(k,3)
2711             ghalf4=0.5d0*agg(k,4)
2712             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2713      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2714             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2715      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2716             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2717      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2718             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2719      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2720 C Derivatives in DC(i+1)
2721             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2722      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2723             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2724      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2725             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2726      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2727             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2728      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2729 C Derivatives in DC(j)
2730             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2731      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2732             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2733      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2734             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2735      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2736             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2737      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2738 C Derivatives in DC(j+1) or DC(nres-1)
2739             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2740      &      -3.0d0*vryg(k,3)*ury)
2741             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2742      &      -3.0d0*vrzg(k,3)*ury)
2743             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2744      &      -3.0d0*vryg(k,3)*urz)
2745             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2746      &      -3.0d0*vrzg(k,3)*urz)
2747 cd            aggi(k,1)=ghalf1
2748 cd            aggi(k,2)=ghalf2
2749 cd            aggi(k,3)=ghalf3
2750 cd            aggi(k,4)=ghalf4
2751 C Derivatives in DC(i+1)
2752 cd            aggi1(k,1)=agg(k,1)
2753 cd            aggi1(k,2)=agg(k,2)
2754 cd            aggi1(k,3)=agg(k,3)
2755 cd            aggi1(k,4)=agg(k,4)
2756 C Derivatives in DC(j)
2757 cd            aggj(k,1)=ghalf1
2758 cd            aggj(k,2)=ghalf2
2759 cd            aggj(k,3)=ghalf3
2760 cd            aggj(k,4)=ghalf4
2761 C Derivatives in DC(j+1)
2762 cd            aggj1(k,1)=0.0d0
2763 cd            aggj1(k,2)=0.0d0
2764 cd            aggj1(k,3)=0.0d0
2765 cd            aggj1(k,4)=0.0d0
2766             if (j.eq.nres-1 .and. i.lt.j-2) then
2767               do l=1,4
2768                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2769 cd                aggj1(k,l)=agg(k,l)
2770               enddo
2771             endif
2772           enddo
2773           endif
2774 c          goto 11111
2775 C Check the loc-el terms by numerical integration
2776           acipa(1,1)=a22
2777           acipa(1,2)=a23
2778           acipa(2,1)=a32
2779           acipa(2,2)=a33
2780           a22=-a22
2781           a23=-a23
2782           do l=1,2
2783             do k=1,3
2784               agg(k,l)=-agg(k,l)
2785               aggi(k,l)=-aggi(k,l)
2786               aggi1(k,l)=-aggi1(k,l)
2787               aggj(k,l)=-aggj(k,l)
2788               aggj1(k,l)=-aggj1(k,l)
2789             enddo
2790           enddo
2791           if (j.lt.nres-1) then
2792             a22=-a22
2793             a32=-a32
2794             do l=1,3,2
2795               do k=1,3
2796                 agg(k,l)=-agg(k,l)
2797                 aggi(k,l)=-aggi(k,l)
2798                 aggi1(k,l)=-aggi1(k,l)
2799                 aggj(k,l)=-aggj(k,l)
2800                 aggj1(k,l)=-aggj1(k,l)
2801               enddo
2802             enddo
2803           else
2804             a22=-a22
2805             a23=-a23
2806             a32=-a32
2807             a33=-a33
2808             do l=1,4
2809               do k=1,3
2810                 agg(k,l)=-agg(k,l)
2811                 aggi(k,l)=-aggi(k,l)
2812                 aggi1(k,l)=-aggi1(k,l)
2813                 aggj(k,l)=-aggj(k,l)
2814                 aggj1(k,l)=-aggj1(k,l)
2815               enddo
2816             enddo
2817           endif
2818           ENDIF ! WCORR
2819 11111     continue
2820           IF (wel_loc.gt.0.0d0) THEN
2821 C Contribution to the local-electrostatic energy coming from the i-j pair
2822           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2823      &     +a33*muij(4)
2824           if (shield_mode.eq.0) then
2825            fac_shield(i)=1.0
2826            fac_shield(j)=1.0
2827 C          else
2828 C           fac_shield(i)=0.4
2829 C           fac_shield(j)=0.6
2830           endif
2831           eel_loc_ij=eel_loc_ij
2832      &    *fac_shield(i)*fac_shield(j)
2833      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2834 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2835 C          write (iout,'(a6,2i5,0pf7.3)')
2836 C     &            'eelloc',i,j,eel_loc_ij
2837 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
2838 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2839 C          eel_loc=eel_loc+eel_loc_ij
2840           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2841      &  (shield_mode.gt.0)) then
2842 C          print *,i,j
2843
2844           do ilist=1,ishield_list(i)
2845            iresshield=shield_list(ilist,i)
2846            do k=1,3
2847            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2848      &                                          /fac_shield(i)
2849 C     &      *2.0
2850            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2851      &              rlocshield
2852      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2853             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2854      &      +rlocshield
2855            enddo
2856           enddo
2857           do ilist=1,ishield_list(j)
2858            iresshield=shield_list(ilist,j)
2859            do k=1,3
2860            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2861      &                                       /fac_shield(j)
2862 C     &     *2.0
2863            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2864      &              rlocshield
2865      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2866            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2867      &             +rlocshield
2868
2869            enddo
2870           enddo
2871           do k=1,3
2872             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2873      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2874             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2875      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2876             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2877      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2878             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2879      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2880            enddo
2881            endif
2882           eel_loc=eel_loc+eel_loc_ij
2883
2884 C Partial derivatives in virtual-bond dihedral angles gamma
2885           if (calc_grad) then
2886           if (i.gt.1)
2887      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2888      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2889      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
2890      &    *fac_shield(i)*fac_shield(j)
2891      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2892
2893           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2894      &            (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2895      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
2896      &    *fac_shield(i)*fac_shield(j)
2897      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2898
2899 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2900 cd          write(iout,*) 'agg  ',agg
2901 cd          write(iout,*) 'aggi ',aggi
2902 cd          write(iout,*) 'aggi1',aggi1
2903 cd          write(iout,*) 'aggj ',aggj
2904 cd          write(iout,*) 'aggj1',aggj1
2905
2906 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2907           do l=1,3
2908             ggg(l)=(agg(l,1)*muij(1)+
2909      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
2910      &    *fac_shield(i)*fac_shield(j)
2911      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2912
2913           enddo
2914           do k=i+2,j2
2915             do l=1,3
2916               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2917             enddo
2918           enddo
2919 C Remaining derivatives of eello
2920           do l=1,3
2921             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
2922      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
2923      &    *fac_shield(i)*fac_shield(j)
2924      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2925
2926             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
2927      &         aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
2928      &    *fac_shield(i)*fac_shield(j)
2929      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2930
2931             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
2932      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
2933      &    *fac_shield(i)*fac_shield(j)
2934      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2935
2936             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
2937      &         aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
2938      &    *fac_shield(i)*fac_shield(j)
2939      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
2940
2941           enddo
2942           endif
2943           ENDIF
2944           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2945 C Contributions from turns
2946             a_temp(1,1)=a22
2947             a_temp(1,2)=a23
2948             a_temp(2,1)=a32
2949             a_temp(2,2)=a33
2950             call eturn34(i,j,eello_turn3,eello_turn4)
2951           endif
2952 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2953           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2954 C
2955 C Calculate the contact function. The ith column of the array JCONT will
2956 C contain the numbers of atoms that make contacts with the atom I (of numbers
2957 C greater than I). The arrays FACONT and GACONT will contain the values of
2958 C the contact function and its derivative.
2959 c           r0ij=1.02D0*rpp(iteli,itelj)
2960 c           r0ij=1.11D0*rpp(iteli,itelj)
2961             r0ij=2.20D0*rpp(iteli,itelj)
2962 c           r0ij=1.55D0*rpp(iteli,itelj)
2963             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2964             if (fcont.gt.0.0D0) then
2965               num_conti=num_conti+1
2966               if (num_conti.gt.maxconts) then
2967                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2968      &                         ' will skip next contacts for this conf.'
2969               else
2970                 jcont_hb(num_conti,i)=j
2971                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2972      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2973 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2974 C  terms.
2975                 d_cont(num_conti,i)=rij
2976 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2977 C     --- Electrostatic-interaction matrix ---
2978                 a_chuj(1,1,num_conti,i)=a22
2979                 a_chuj(1,2,num_conti,i)=a23
2980                 a_chuj(2,1,num_conti,i)=a32
2981                 a_chuj(2,2,num_conti,i)=a33
2982 C     --- Gradient of rij
2983                 do kkk=1,3
2984                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2985                 enddo
2986 c             if (i.eq.1) then
2987 c                a_chuj(1,1,num_conti,i)=-0.61d0
2988 c                a_chuj(1,2,num_conti,i)= 0.4d0
2989 c                a_chuj(2,1,num_conti,i)= 0.65d0
2990 c                a_chuj(2,2,num_conti,i)= 0.50d0
2991 c             else if (i.eq.2) then
2992 c                a_chuj(1,1,num_conti,i)= 0.0d0
2993 c                a_chuj(1,2,num_conti,i)= 0.0d0
2994 c                a_chuj(2,1,num_conti,i)= 0.0d0
2995 c                a_chuj(2,2,num_conti,i)= 0.0d0
2996 c             endif
2997 C     --- and its gradients
2998 cd                write (iout,*) 'i',i,' j',j
2999 cd                do kkk=1,3
3000 cd                write (iout,*) 'iii 1 kkk',kkk
3001 cd                write (iout,*) agg(kkk,:)
3002 cd                enddo
3003 cd                do kkk=1,3
3004 cd                write (iout,*) 'iii 2 kkk',kkk
3005 cd                write (iout,*) aggi(kkk,:)
3006 cd                enddo
3007 cd                do kkk=1,3
3008 cd                write (iout,*) 'iii 3 kkk',kkk
3009 cd                write (iout,*) aggi1(kkk,:)
3010 cd                enddo
3011 cd                do kkk=1,3
3012 cd                write (iout,*) 'iii 4 kkk',kkk
3013 cd                write (iout,*) aggj(kkk,:)
3014 cd                enddo
3015 cd                do kkk=1,3
3016 cd                write (iout,*) 'iii 5 kkk',kkk
3017 cd                write (iout,*) aggj1(kkk,:)
3018 cd                enddo
3019                 kkll=0
3020                 do k=1,2
3021                   do l=1,2
3022                     kkll=kkll+1
3023                     do m=1,3
3024                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3025                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3026                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3027                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3028                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3029 c                      do mm=1,5
3030 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
3031 c                      enddo
3032                     enddo
3033                   enddo
3034                 enddo
3035                 ENDIF
3036                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3037 C Calculate contact energies
3038                 cosa4=4.0D0*cosa
3039                 wij=cosa-3.0D0*cosb*cosg
3040                 cosbg1=cosb+cosg
3041                 cosbg2=cosb-cosg
3042 c               fac3=dsqrt(-ael6i)/r0ij**3
3043                 fac3=dsqrt(-ael6i)*r3ij
3044                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3045                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3046 c               ees0mij=0.0D0
3047                 if (shield_mode.eq.0) then
3048                 fac_shield(i)=1.0d0
3049                 fac_shield(j)=1.0d0
3050                 else
3051                 ees0plist(num_conti,i)=j
3052 C                fac_shield(i)=0.4d0
3053 C                fac_shield(j)=0.6d0
3054                 endif
3055                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3056      &          *fac_shield(i)*fac_shield(j)
3057
3058                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3059      &          *fac_shield(i)*fac_shield(j)
3060
3061 C Diagnostics. Comment out or remove after debugging!
3062 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3063 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3064 c               ees0m(num_conti,i)=0.0D0
3065 C End diagnostics.
3066 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3067 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3068                 facont_hb(num_conti,i)=fcont
3069                 if (calc_grad) then
3070 C Angular derivatives of the contact function
3071                 ees0pij1=fac3/ees0pij
3072                 ees0mij1=fac3/ees0mij
3073                 fac3p=-3.0D0*fac3*rrmij
3074                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3075                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3076 c               ees0mij1=0.0D0
3077                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3078                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3079                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3080                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3081                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3082                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3083                 ecosap=ecosa1+ecosa2
3084                 ecosbp=ecosb1+ecosb2
3085                 ecosgp=ecosg1+ecosg2
3086                 ecosam=ecosa1-ecosa2
3087                 ecosbm=ecosb1-ecosb2
3088                 ecosgm=ecosg1-ecosg2
3089 C Diagnostics
3090 c               ecosap=ecosa1
3091 c               ecosbp=ecosb1
3092 c               ecosgp=ecosg1
3093 c               ecosam=0.0D0
3094 c               ecosbm=0.0D0
3095 c               ecosgm=0.0D0
3096 C End diagnostics
3097                 fprimcont=fprimcont/rij
3098 cd              facont_hb(num_conti,i)=1.0D0
3099 C Following line is for diagnostics.
3100 cd              fprimcont=0.0D0
3101                 do k=1,3
3102                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3103                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3104                 enddo
3105                 do k=1,3
3106                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3107                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3108                 enddo
3109                 gggp(1)=gggp(1)+ees0pijp*xj
3110                 gggp(2)=gggp(2)+ees0pijp*yj
3111                 gggp(3)=gggp(3)+ees0pijp*zj
3112                 gggm(1)=gggm(1)+ees0mijp*xj
3113                 gggm(2)=gggm(2)+ees0mijp*yj
3114                 gggm(3)=gggm(3)+ees0mijp*zj
3115 C Derivatives due to the contact function
3116                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3117                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3118                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3119                 do k=1,3
3120                   ghalfp=0.5D0*gggp(k)
3121                   ghalfm=0.5D0*gggm(k)
3122                   gacontp_hb1(k,num_conti,i)=ghalfp
3123      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3124      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3125      &          *fac_shield(i)*fac_shield(j)
3126
3127                   gacontp_hb2(k,num_conti,i)=ghalfp
3128      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3129      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3130      &          *fac_shield(i)*fac_shield(j)
3131
3132                   gacontp_hb3(k,num_conti,i)=gggp(k)
3133      &          *fac_shield(i)*fac_shield(j)
3134
3135                   gacontm_hb1(k,num_conti,i)=ghalfm
3136      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3137      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3138      &          *fac_shield(i)*fac_shield(j)
3139
3140                   gacontm_hb2(k,num_conti,i)=ghalfm
3141      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3142      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3143      &          *fac_shield(i)*fac_shield(j)
3144
3145                   gacontm_hb3(k,num_conti,i)=gggm(k)
3146      &          *fac_shield(i)*fac_shield(j)
3147
3148                 enddo
3149                 endif
3150 C Diagnostics. Comment out or remove after debugging!
3151 cdiag           do k=1,3
3152 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3153 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3154 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3155 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3156 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3157 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3158 cdiag           enddo
3159               ENDIF ! wcorr
3160               endif  ! num_conti.le.maxconts
3161             endif  ! fcont.gt.0
3162           endif    ! j.gt.i+1
3163  1216     continue
3164         enddo ! j
3165         num_cont_hb(i)=num_conti
3166  1215   continue
3167       enddo   ! i
3168 cd      do i=1,nres
3169 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3170 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3171 cd      enddo
3172 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3173 ccc      eel_loc=eel_loc+eello_turn3
3174       return
3175       end
3176 C-----------------------------------------------------------------------------
3177       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3178 C Third- and fourth-order contributions from turns
3179       implicit real*8 (a-h,o-z)
3180       include 'DIMENSIONS'
3181       include 'DIMENSIONS.ZSCOPT'
3182       include 'COMMON.IOUNITS'
3183       include 'COMMON.GEO'
3184       include 'COMMON.VAR'
3185       include 'COMMON.LOCAL'
3186       include 'COMMON.CHAIN'
3187       include 'COMMON.DERIV'
3188       include 'COMMON.INTERACT'
3189       include 'COMMON.CONTACTS'
3190       include 'COMMON.TORSION'
3191       include 'COMMON.VECTORS'
3192       include 'COMMON.FFIELD'
3193       include 'COMMON.SHIELD'
3194       include 'COMMON.CONTROL'
3195       dimension ggg(3)
3196       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3197      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3198      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3199       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3200      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3201       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3202           zj=(c(3,j)+c(3,j+1))/2.0d0
3203 C          xj=mod(xj,boxxsize)
3204 C          if (xj.lt.0) xj=xj+boxxsize
3205 C          yj=mod(yj,boxysize)
3206 C          if (yj.lt.0) yj=yj+boxysize
3207           zj=mod(zj,boxzsize)
3208           if (zj.lt.0) zj=zj+boxzsize
3209 C          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3210        if ((zj.gt.bordlipbot)
3211      &.and.(zj.lt.bordliptop)) then
3212 C the energy transfer exist
3213         if (zj.lt.buflipbot) then
3214 C what fraction I am in
3215          fracinbuf=1.0d0-
3216      &        ((zj-bordlipbot)/lipbufthick)
3217 C lipbufthick is thickenes of lipid buffore
3218          sslipj=sscalelip(fracinbuf)
3219          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3220         elseif (zj.gt.bufliptop) then
3221          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3222          sslipj=sscalelip(fracinbuf)
3223          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3224         else
3225          sslipj=1.0d0
3226          ssgradlipj=0.0
3227         endif
3228        else
3229          sslipj=0.0d0
3230          ssgradlipj=0.0
3231        endif
3232
3233       if (j.eq.i+2) then
3234       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3235 C changes suggested by Ana to avoid out of bounds
3236 C     & .or.((i+5).gt.nres)
3237 C     & .or.((i-1).le.0)
3238 C end of changes suggested by Ana
3239      &    .or. itype(i+2).eq.ntyp1
3240      &    .or. itype(i+3).eq.ntyp1
3241 C     &    .or. itype(i+5).eq.ntyp1
3242 C     &    .or. itype(i).eq.ntyp1
3243 C     &    .or. itype(i-1).eq.ntyp1
3244      &    ) goto 179
3245
3246 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3247 C
3248 C               Third-order contributions
3249 C
3250 C                 (i+2)o----(i+3)
3251 C                      | |
3252 C                      | |
3253 C                 (i+1)o----i
3254 C
3255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3256 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3257         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3258         call transpose2(auxmat(1,1),auxmat1(1,1))
3259         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3260         if (shield_mode.eq.0) then
3261         fac_shield(i)=1.0
3262         fac_shield(j)=1.0
3263 C        else
3264 C        fac_shield(i)=0.4
3265 C        fac_shield(j)=0.6
3266         endif
3267
3268         eello_turn3=eello_turn3+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         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3273      &  *fac_shield(i)*fac_shield(j)
3274      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3275
3276 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3277 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3278 cd     &    ' eello_turn3_num',4*eello_turn3_num
3279         if (calc_grad) then
3280 C Derivatives in shield mode
3281           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3282      &  (shield_mode.gt.0)) then
3283 C          print *,i,j
3284
3285           do ilist=1,ishield_list(i)
3286            iresshield=shield_list(ilist,i)
3287            do k=1,3
3288            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3289 C     &      *2.0
3290            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3291      &              rlocshield
3292      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3293             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3294      &      +rlocshield
3295            enddo
3296           enddo
3297           do ilist=1,ishield_list(j)
3298            iresshield=shield_list(ilist,j)
3299            do k=1,3
3300            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3301 C     &     *2.0
3302            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3303      &              rlocshield
3304      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3305            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3306      &             +rlocshield
3307
3308            enddo
3309           enddo
3310
3311           do k=1,3
3312             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3313      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3314             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3315      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3316             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3317      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3318             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3319      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3320            enddo
3321            endif
3322
3323 C Derivatives in gamma(i)
3324         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3325         call transpose2(auxmat2(1,1),pizda(1,1))
3326         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3327         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3328      &   *fac_shield(i)*fac_shield(j)
3329      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3330
3331 C Derivatives in gamma(i+1)
3332         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3333         call transpose2(auxmat2(1,1),pizda(1,1))
3334         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3335         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3336      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3337      &   *fac_shield(i)*fac_shield(j)
3338      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3339
3340 C Cartesian derivatives
3341         do l=1,3
3342           a_temp(1,1)=aggi(l,1)
3343           a_temp(1,2)=aggi(l,2)
3344           a_temp(2,1)=aggi(l,3)
3345           a_temp(2,2)=aggi(l,4)
3346           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3347           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3348      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3349      &   *fac_shield(i)*fac_shield(j)
3350      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3351
3352           a_temp(1,1)=aggi1(l,1)
3353           a_temp(1,2)=aggi1(l,2)
3354           a_temp(2,1)=aggi1(l,3)
3355           a_temp(2,2)=aggi1(l,4)
3356           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3357           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3358      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3359      &   *fac_shield(i)*fac_shield(j)
3360      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3361
3362           a_temp(1,1)=aggj(l,1)
3363           a_temp(1,2)=aggj(l,2)
3364           a_temp(2,1)=aggj(l,3)
3365           a_temp(2,2)=aggj(l,4)
3366           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3367           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3368      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3369      &   *fac_shield(i)*fac_shield(j)
3370      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3371
3372           a_temp(1,1)=aggj1(l,1)
3373           a_temp(1,2)=aggj1(l,2)
3374           a_temp(2,1)=aggj1(l,3)
3375           a_temp(2,2)=aggj1(l,4)
3376           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3377           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3378      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3379      &   *fac_shield(i)*fac_shield(j)
3380      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3381
3382         enddo
3383         endif
3384   179 continue
3385       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3386       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3387 C changes suggested by Ana to avoid out of bounds
3388 C     & .or.((i+5).gt.nres)
3389 C     & .or.((i-1).le.0)
3390 C end of changes suggested by Ana
3391      &    .or. itype(i+3).eq.ntyp1
3392      &    .or. itype(i+4).eq.ntyp1
3393 C     &    .or. itype(i+5).eq.ntyp1
3394      &    .or. itype(i).eq.ntyp1
3395 C     &    .or. itype(i-1).eq.ntyp1
3396      &    ) goto 178
3397 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3398 C
3399 C               Fourth-order contributions
3400 C
3401 C                 (i+3)o----(i+4)
3402 C                     /  |
3403 C               (i+2)o   |
3404 C                     \  |
3405 C                 (i+1)o----i
3406 C
3407 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3408 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3409         iti1=itortyp(itype(i+1))
3410         iti2=itortyp(itype(i+2))
3411         iti3=itortyp(itype(i+3))
3412         call transpose2(EUg(1,1,i+1),e1t(1,1))
3413         call transpose2(Eug(1,1,i+2),e2t(1,1))
3414         call transpose2(Eug(1,1,i+3),e3t(1,1))
3415         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3416         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3417         s1=scalar2(b1(1,iti2),auxvec(1))
3418         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3419         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3420         s2=scalar2(b1(1,iti1),auxvec(1))
3421         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3422         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3423         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3424         if (shield_mode.eq.0) then
3425         fac_shield(i)=1.0
3426         fac_shield(j)=1.0
3427 C        else
3428 C        fac_shield(i)=0.4
3429 C        fac_shield(j)=0.6
3430         endif
3431
3432         eello_turn4=eello_turn4-(s1+s2+s3)
3433      &  *fac_shield(i)*fac_shield(j)
3434         eello_t4=-(s1+s2+s3)
3435      &  *fac_shield(i)*fac_shield(j)
3436
3437 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3438 cd     &    ' eello_turn4_num',8*eello_turn4_num
3439 C Derivatives in gamma(i)
3440         if (calc_grad) then
3441           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3442      &  (shield_mode.gt.0)) then
3443 C          print *,i,j
3444
3445           do ilist=1,ishield_list(i)
3446            iresshield=shield_list(ilist,i)
3447            do k=1,3
3448            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3449 C     &      *2.0
3450            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3451      &              rlocshield
3452      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3453             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3454      &      +rlocshield
3455            enddo
3456           enddo
3457           do ilist=1,ishield_list(j)
3458            iresshield=shield_list(ilist,j)
3459            do k=1,3
3460            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3461 C     &     *2.0
3462            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3463      &              rlocshield
3464      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3465            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3466      &             +rlocshield
3467
3468            enddo
3469           enddo
3470
3471           do k=1,3
3472             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3473      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3474             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3475      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3476             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3477      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3478             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3479      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3480            enddo
3481            endif
3482         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3483         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3484         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3485         s1=scalar2(b1(1,iti2),auxvec(1))
3486         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3487         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3488         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3489      &  *fac_shield(i)*fac_shield(j)
3490      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3491
3492 C Derivatives in gamma(i+1)
3493         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3494         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3495         s2=scalar2(b1(1,iti1),auxvec(1))
3496         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3497         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3498         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3499         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3500      &  *fac_shield(i)*fac_shield(j)
3501      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3502
3503 C Derivatives in gamma(i+2)
3504         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3505         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3506         s1=scalar2(b1(1,iti2),auxvec(1))
3507         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3508         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3509         s2=scalar2(b1(1,iti1),auxvec(1))
3510         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3511         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3512         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3513         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3514      &  *fac_shield(i)*fac_shield(j)
3515      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3516
3517 C Cartesian derivatives
3518
3519 C Derivatives of this turn contributions in DC(i+2)
3520         if (j.lt.nres-1) then
3521           do l=1,3
3522             a_temp(1,1)=agg(l,1)
3523             a_temp(1,2)=agg(l,2)
3524             a_temp(2,1)=agg(l,3)
3525             a_temp(2,2)=agg(l,4)
3526             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3527             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3528             s1=scalar2(b1(1,iti2),auxvec(1))
3529             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3530             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3531             s2=scalar2(b1(1,iti1),auxvec(1))
3532             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3533             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3534             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3535             ggg(l)=-(s1+s2+s3)
3536             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3537      &  *fac_shield(i)*fac_shield(j)
3538      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3539
3540           enddo
3541         endif
3542 C Remaining derivatives of this turn contribution
3543         do l=1,3
3544           a_temp(1,1)=aggi(l,1)
3545           a_temp(1,2)=aggi(l,2)
3546           a_temp(2,1)=aggi(l,3)
3547           a_temp(2,2)=aggi(l,4)
3548           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3549           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3550           s1=scalar2(b1(1,iti2),auxvec(1))
3551           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3552           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3553           s2=scalar2(b1(1,iti1),auxvec(1))
3554           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3555           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3556           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3557           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3558      &  *fac_shield(i)*fac_shield(j)
3559      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3560
3561           a_temp(1,1)=aggi1(l,1)
3562           a_temp(1,2)=aggi1(l,2)
3563           a_temp(2,1)=aggi1(l,3)
3564           a_temp(2,2)=aggi1(l,4)
3565           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3566           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3567           s1=scalar2(b1(1,iti2),auxvec(1))
3568           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3569           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3570           s2=scalar2(b1(1,iti1),auxvec(1))
3571           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3572           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3573           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3574           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3575      &  *fac_shield(i)*fac_shield(j)
3576      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3577
3578           a_temp(1,1)=aggj(l,1)
3579           a_temp(1,2)=aggj(l,2)
3580           a_temp(2,1)=aggj(l,3)
3581           a_temp(2,2)=aggj(l,4)
3582           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3583           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3584           s1=scalar2(b1(1,iti2),auxvec(1))
3585           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3586           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3587           s2=scalar2(b1(1,iti1),auxvec(1))
3588           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3589           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3590           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3591           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3592      &  *fac_shield(i)*fac_shield(j)
3593      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3594
3595           a_temp(1,1)=aggj1(l,1)
3596           a_temp(1,2)=aggj1(l,2)
3597           a_temp(2,1)=aggj1(l,3)
3598           a_temp(2,2)=aggj1(l,4)
3599           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3600           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3601           s1=scalar2(b1(1,iti2),auxvec(1))
3602           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3603           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3604           s2=scalar2(b1(1,iti1),auxvec(1))
3605           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3606           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3607           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3608           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3609      &  *fac_shield(i)*fac_shield(j)
3610      &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3611
3612         enddo
3613          gshieldc_t4(3,i)=gshieldc_t4(3,i)+
3614      &     ssgradlipi*eello_t4/4.0d0*lipscale
3615          gshieldc_t4(3,j)=gshieldc_t4(3,j)+
3616      &     ssgradlipj*eello_t4/4.0d0*lipscale
3617          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
3618      &     ssgradlipi*eello_t4/4.0d0*lipscale
3619          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
3620      &     ssgradlipj*eello_t4/4.0d0*lipscale
3621         endif
3622  178  continue
3623       endif
3624       return
3625       end
3626 C-----------------------------------------------------------------------------
3627       subroutine vecpr(u,v,w)
3628       implicit real*8(a-h,o-z)
3629       dimension u(3),v(3),w(3)
3630       w(1)=u(2)*v(3)-u(3)*v(2)
3631       w(2)=-u(1)*v(3)+u(3)*v(1)
3632       w(3)=u(1)*v(2)-u(2)*v(1)
3633       return
3634       end
3635 C-----------------------------------------------------------------------------
3636       subroutine unormderiv(u,ugrad,unorm,ungrad)
3637 C This subroutine computes the derivatives of a normalized vector u, given
3638 C the derivatives computed without normalization conditions, ugrad. Returns
3639 C ungrad.
3640       implicit none
3641       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3642       double precision vec(3)
3643       double precision scalar
3644       integer i,j
3645 c      write (2,*) 'ugrad',ugrad
3646 c      write (2,*) 'u',u
3647       do i=1,3
3648         vec(i)=scalar(ugrad(1,i),u(1))
3649       enddo
3650 c      write (2,*) 'vec',vec
3651       do i=1,3
3652         do j=1,3
3653           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3654         enddo
3655       enddo
3656 c      write (2,*) 'ungrad',ungrad
3657       return
3658       end
3659 C-----------------------------------------------------------------------------
3660       subroutine escp(evdw2,evdw2_14)
3661 C
3662 C This subroutine calculates the excluded-volume interaction energy between
3663 C peptide-group centers and side chains and its gradient in virtual-bond and
3664 C side-chain vectors.
3665 C
3666       implicit real*8 (a-h,o-z)
3667       include 'DIMENSIONS'
3668       include 'DIMENSIONS.ZSCOPT'
3669       include 'COMMON.GEO'
3670       include 'COMMON.VAR'
3671       include 'COMMON.LOCAL'
3672       include 'COMMON.CHAIN'
3673       include 'COMMON.DERIV'
3674       include 'COMMON.INTERACT'
3675       include 'COMMON.FFIELD'
3676       include 'COMMON.IOUNITS'
3677       dimension ggg(3)
3678       evdw2=0.0D0
3679       evdw2_14=0.0d0
3680 cd    print '(a)','Enter ESCP'
3681 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3682 c     &  ' scal14',scal14
3683       do i=iatscp_s,iatscp_e
3684         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3685         iteli=itel(i)
3686 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3687 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3688         if (iteli.eq.0) goto 1225
3689         xi=0.5D0*(c(1,i)+c(1,i+1))
3690         yi=0.5D0*(c(2,i)+c(2,i+1))
3691         zi=0.5D0*(c(3,i)+c(3,i+1))
3692 C Returning the ith atom to box
3693           xi=mod(xi,boxxsize)
3694           if (xi.lt.0) xi=xi+boxxsize
3695           yi=mod(yi,boxysize)
3696           if (yi.lt.0) yi=yi+boxysize
3697           zi=mod(zi,boxzsize)
3698           if (zi.lt.0) zi=zi+boxzsize
3699         do iint=1,nscp_gr(i)
3700
3701         do j=iscpstart(i,iint),iscpend(i,iint)
3702           itypj=iabs(itype(j))
3703           if (itypj.eq.ntyp1) cycle
3704 C Uncomment following three lines for SC-p interactions
3705 c         xj=c(1,nres+j)-xi
3706 c         yj=c(2,nres+j)-yi
3707 c         zj=c(3,nres+j)-zi
3708 C Uncomment following three lines for Ca-p interactions
3709           xj=c(1,j)
3710           yj=c(2,j)
3711           zj=c(3,j)
3712 C returning the jth atom to box
3713           xj=mod(xj,boxxsize)
3714           if (xj.lt.0) xj=xj+boxxsize
3715           yj=mod(yj,boxysize)
3716           if (yj.lt.0) yj=yj+boxysize
3717           zj=mod(zj,boxzsize)
3718           if (zj.lt.0) zj=zj+boxzsize
3719       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3720       xj_safe=xj
3721       yj_safe=yj
3722       zj_safe=zj
3723       subchap=0
3724 C Finding the closest jth atom
3725       do xshift=-1,1
3726       do yshift=-1,1
3727       do zshift=-1,1
3728           xj=xj_safe+xshift*boxxsize
3729           yj=yj_safe+yshift*boxysize
3730           zj=zj_safe+zshift*boxzsize
3731           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3732           if(dist_temp.lt.dist_init) then
3733             dist_init=dist_temp
3734             xj_temp=xj
3735             yj_temp=yj
3736             zj_temp=zj
3737             subchap=1
3738           endif
3739        enddo
3740        enddo
3741        enddo
3742        if (subchap.eq.1) then
3743           xj=xj_temp-xi
3744           yj=yj_temp-yi
3745           zj=zj_temp-zi
3746        else
3747           xj=xj_safe-xi
3748           yj=yj_safe-yi
3749           zj=zj_safe-zi
3750        endif
3751           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3752 C sss is scaling function for smoothing the cutoff gradient otherwise
3753 C the gradient would not be continuouse
3754           sss=sscale(1.0d0/(dsqrt(rrij)))
3755           if (sss.le.0.0d0) cycle
3756           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3757           fac=rrij**expon2
3758           e1=fac*fac*aad(itypj,iteli)
3759           e2=fac*bad(itypj,iteli)
3760           if (iabs(j-i) .le. 2) then
3761             e1=scal14*e1
3762             e2=scal14*e2
3763             evdw2_14=evdw2_14+(e1+e2)*sss
3764           endif
3765           evdwij=e1+e2
3766 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3767 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3768 c     &       bad(itypj,iteli)
3769           evdw2=evdw2+evdwij*sss
3770           if (calc_grad) then
3771 C
3772 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3773 C
3774           fac=-(evdwij+e1)*rrij*sss
3775           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3776           ggg(1)=xj*fac
3777           ggg(2)=yj*fac
3778           ggg(3)=zj*fac
3779           if (j.lt.i) then
3780 cd          write (iout,*) 'j<i'
3781 C Uncomment following three lines for SC-p interactions
3782 c           do k=1,3
3783 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3784 c           enddo
3785           else
3786 cd          write (iout,*) 'j>i'
3787             do k=1,3
3788               ggg(k)=-ggg(k)
3789 C Uncomment following line for SC-p interactions
3790 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3791             enddo
3792           endif
3793           do k=1,3
3794             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3795           enddo
3796           kstart=min0(i+1,j)
3797           kend=max0(i-1,j-1)
3798 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3799 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3800           do k=kstart,kend
3801             do l=1,3
3802               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3803             enddo
3804           enddo
3805           endif
3806         enddo
3807         enddo ! iint
3808  1225   continue
3809       enddo ! i
3810       do i=1,nct
3811         do j=1,3
3812           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3813           gradx_scp(j,i)=expon*gradx_scp(j,i)
3814         enddo
3815       enddo
3816 C******************************************************************************
3817 C
3818 C                              N O T E !!!
3819 C
3820 C To save time the factor EXPON has been extracted from ALL components
3821 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3822 C use!
3823 C
3824 C******************************************************************************
3825       return
3826       end
3827 C--------------------------------------------------------------------------
3828       subroutine edis(ehpb)
3829 C
3830 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3831 C
3832       implicit real*8 (a-h,o-z)
3833       include 'DIMENSIONS'
3834       include 'DIMENSIONS.ZSCOPT'
3835       include 'COMMON.SBRIDGE'
3836       include 'COMMON.CHAIN'
3837       include 'COMMON.DERIV'
3838       include 'COMMON.VAR'
3839       include 'COMMON.INTERACT'
3840       include 'COMMON.CONTROL'
3841       include 'COMMON.IOUNITS'
3842       dimension ggg(3)
3843       ehpb=0.0D0
3844 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3845 cd    print *,'link_start=',link_start,' link_end=',link_end
3846 C      write(iout,*) link_end, "link_end"
3847       if (link_end.eq.0) return
3848       do i=link_start,link_end
3849 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3850 C CA-CA distance used in regularization of structure.
3851         ii=ihpb(i)
3852         jj=jhpb(i)
3853 C iii and jjj point to the residues for which the distance is assigned.
3854         if (ii.gt.nres) then
3855           iii=ii-nres
3856           jjj=jj-nres
3857         else
3858           iii=ii
3859           jjj=jj
3860         endif
3861 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3862 C    distance and angle dependent SS bond potential.
3863 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3864 C     & iabs(itype(jjj)).eq.1) then
3865 C       write(iout,*) constr_dist,"const"
3866        if (.not.dyn_ss .and. i.le.nss) then
3867          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3868      & iabs(itype(jjj)).eq.1) then
3869           call ssbond_ene(iii,jjj,eij)
3870           ehpb=ehpb+2*eij
3871            endif !ii.gt.neres
3872         else if (ii.gt.nres .and. jj.gt.nres) then
3873 c Restraints from contact prediction
3874           dd=dist(ii,jj)
3875           if (constr_dist.eq.11) then
3876 C            ehpb=ehpb+fordepth(i)**4.0d0
3877 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3878             ehpb=ehpb+fordepth(i)**4.0d0
3879      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3880             fac=fordepth(i)**4.0d0
3881      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3882 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3883 C     &    ehpb,fordepth(i),dd
3884 C            write(iout,*) ehpb,"atu?"
3885 C            ehpb,"tu?"
3886 C            fac=fordepth(i)**4.0d0
3887 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3888            else
3889           if (dhpb1(i).gt.0.0d0) then
3890             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3891             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3892 c            write (iout,*) "beta nmr",
3893 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3894           else
3895             dd=dist(ii,jj)
3896             rdis=dd-dhpb(i)
3897 C Get the force constant corresponding to this distance.
3898             waga=forcon(i)
3899 C Calculate the contribution to energy.
3900             ehpb=ehpb+waga*rdis*rdis
3901 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3902 C
3903 C Evaluate gradient.
3904 C
3905             fac=waga*rdis/dd
3906           endif !end dhpb1(i).gt.0
3907           endif !end const_dist=11
3908           do j=1,3
3909             ggg(j)=fac*(c(j,jj)-c(j,ii))
3910           enddo
3911           do j=1,3
3912             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3913             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3914           enddo
3915           do k=1,3
3916             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3917             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3918           enddo
3919         else !ii.gt.nres
3920 C          write(iout,*) "before"
3921           dd=dist(ii,jj)
3922 C          write(iout,*) "after",dd
3923           if (constr_dist.eq.11) then
3924             ehpb=ehpb+fordepth(i)**4.0d0
3925      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3926             fac=fordepth(i)**4.0d0
3927      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3928 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3929 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3930 C            print *,ehpb,"tu?"
3931 C            write(iout,*) ehpb,"btu?",
3932 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3933 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3934 C     &    ehpb,fordepth(i),dd
3935            else
3936           if (dhpb1(i).gt.0.0d0) then
3937             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3938             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3939 c            write (iout,*) "alph nmr",
3940 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3941           else
3942             rdis=dd-dhpb(i)
3943 C Get the force constant corresponding to this distance.
3944             waga=forcon(i)
3945 C Calculate the contribution to energy.
3946             ehpb=ehpb+waga*rdis*rdis
3947 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3948 C
3949 C Evaluate gradient.
3950 C
3951             fac=waga*rdis/dd
3952           endif
3953           endif
3954
3955         do j=1,3
3956           ggg(j)=fac*(c(j,jj)-c(j,ii))
3957         enddo
3958 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3959 C If this is a SC-SC distance, we need to calculate the contributions to the
3960 C Cartesian gradient in the SC vectors (ghpbx).
3961         if (iii.lt.ii) then
3962           do j=1,3
3963             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3964             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3965           enddo
3966         endif
3967         do j=iii,jjj-1
3968           do k=1,3
3969             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3970           enddo
3971         enddo
3972         endif
3973       enddo
3974       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3975       return
3976       end
3977 C--------------------------------------------------------------------------
3978       subroutine ssbond_ene(i,j,eij)
3979 C
3980 C Calculate the distance and angle dependent SS-bond potential energy
3981 C using a free-energy function derived based on RHF/6-31G** ab initio
3982 C calculations of diethyl disulfide.
3983 C
3984 C A. Liwo and U. Kozlowska, 11/24/03
3985 C
3986       implicit real*8 (a-h,o-z)
3987       include 'DIMENSIONS'
3988       include 'DIMENSIONS.ZSCOPT'
3989       include 'COMMON.SBRIDGE'
3990       include 'COMMON.CHAIN'
3991       include 'COMMON.DERIV'
3992       include 'COMMON.LOCAL'
3993       include 'COMMON.INTERACT'
3994       include 'COMMON.VAR'
3995       include 'COMMON.IOUNITS'
3996       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3997       itypi=iabs(itype(i))
3998       xi=c(1,nres+i)
3999       yi=c(2,nres+i)
4000       zi=c(3,nres+i)
4001       dxi=dc_norm(1,nres+i)
4002       dyi=dc_norm(2,nres+i)
4003       dzi=dc_norm(3,nres+i)
4004       dsci_inv=dsc_inv(itypi)
4005       itypj=iabs(itype(j))
4006       dscj_inv=dsc_inv(itypj)
4007       xj=c(1,nres+j)-xi
4008       yj=c(2,nres+j)-yi
4009       zj=c(3,nres+j)-zi
4010       dxj=dc_norm(1,nres+j)
4011       dyj=dc_norm(2,nres+j)
4012       dzj=dc_norm(3,nres+j)
4013       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4014       rij=dsqrt(rrij)
4015       erij(1)=xj*rij
4016       erij(2)=yj*rij
4017       erij(3)=zj*rij
4018       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4019       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4020       om12=dxi*dxj+dyi*dyj+dzi*dzj
4021       do k=1,3
4022         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4023         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4024       enddo
4025       rij=1.0d0/rij
4026       deltad=rij-d0cm
4027       deltat1=1.0d0-om1
4028       deltat2=1.0d0+om2
4029       deltat12=om2-om1+2.0d0
4030       cosphi=om12-om1*om2
4031       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4032      &  +akct*deltad*deltat12
4033      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4034 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4035 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4036 c     &  " deltat12",deltat12," eij",eij
4037       ed=2*akcm*deltad+akct*deltat12
4038       pom1=akct*deltad
4039       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4040       eom1=-2*akth*deltat1-pom1-om2*pom2
4041       eom2= 2*akth*deltat2+pom1-om1*pom2
4042       eom12=pom2
4043       do k=1,3
4044         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4045       enddo
4046       do k=1,3
4047         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4048      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4049         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4050      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4051       enddo
4052 C
4053 C Calculate the components of the gradient in DC and X
4054 C
4055       do k=i,j-1
4056         do l=1,3
4057           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4058         enddo
4059       enddo
4060       return
4061       end
4062 C--------------------------------------------------------------------------
4063       subroutine ebond(estr)
4064 c
4065 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4066 c
4067       implicit real*8 (a-h,o-z)
4068       include 'DIMENSIONS'
4069       include 'DIMENSIONS.ZSCOPT'
4070       include 'COMMON.LOCAL'
4071       include 'COMMON.GEO'
4072       include 'COMMON.INTERACT'
4073       include 'COMMON.DERIV'
4074       include 'COMMON.VAR'
4075       include 'COMMON.CHAIN'
4076       include 'COMMON.IOUNITS'
4077       include 'COMMON.NAMES'
4078       include 'COMMON.FFIELD'
4079       include 'COMMON.CONTROL'
4080       logical energy_dec /.false./
4081       double precision u(3),ud(3)
4082       estr=0.0d0
4083       estr1=0.0d0
4084 c      write (iout,*) "distchainmax",distchainmax
4085       do i=nnt+1,nct
4086         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4087 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4088 C          do j=1,3
4089 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4090 C     &      *dc(j,i-1)/vbld(i)
4091 C          enddo
4092 C          if (energy_dec) write(iout,*)
4093 C     &       "estr1",i,vbld(i),distchainmax,
4094 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4095 C        else
4096          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4097         diff = vbld(i)-vbldpDUM
4098 C         write(iout,*) i,diff
4099          else
4100           diff = vbld(i)-vbldp0
4101 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4102          endif
4103           estr=estr+diff*diff
4104           do j=1,3
4105             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4106           enddo
4107 C        endif
4108 C        write (iout,'(a7,i5,4f7.3)')
4109 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4110       enddo
4111       estr=0.5d0*AKP*estr+estr1
4112 c
4113 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4114 c
4115       do i=nnt,nct
4116         iti=iabs(itype(i))
4117         if (iti.ne.10 .and. iti.ne.ntyp1) then
4118           nbi=nbondterm(iti)
4119           if (nbi.eq.1) then
4120             diff=vbld(i+nres)-vbldsc0(1,iti)
4121 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4122 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4123             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4124             do j=1,3
4125               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4126             enddo
4127           else
4128             do j=1,nbi
4129               diff=vbld(i+nres)-vbldsc0(j,iti)
4130               ud(j)=aksc(j,iti)*diff
4131               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4132             enddo
4133             uprod=u(1)
4134             do j=2,nbi
4135               uprod=uprod*u(j)
4136             enddo
4137             usum=0.0d0
4138             usumsqder=0.0d0
4139             do j=1,nbi
4140               uprod1=1.0d0
4141               uprod2=1.0d0
4142               do k=1,nbi
4143                 if (k.ne.j) then
4144                   uprod1=uprod1*u(k)
4145                   uprod2=uprod2*u(k)*u(k)
4146                 endif
4147               enddo
4148               usum=usum+uprod1
4149               usumsqder=usumsqder+ud(j)*uprod2
4150             enddo
4151 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4152 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4153             estr=estr+uprod/usum
4154             do j=1,3
4155              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4156             enddo
4157           endif
4158         endif
4159       enddo
4160       return
4161       end
4162 #ifdef CRYST_THETA
4163 C--------------------------------------------------------------------------
4164       subroutine ebend(etheta,ethetacnstr)
4165 C
4166 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4167 C angles gamma and its derivatives in consecutive thetas and gammas.
4168 C
4169       implicit real*8 (a-h,o-z)
4170       include 'DIMENSIONS'
4171       include 'DIMENSIONS.ZSCOPT'
4172       include 'COMMON.LOCAL'
4173       include 'COMMON.GEO'
4174       include 'COMMON.INTERACT'
4175       include 'COMMON.DERIV'
4176       include 'COMMON.VAR'
4177       include 'COMMON.CHAIN'
4178       include 'COMMON.IOUNITS'
4179       include 'COMMON.NAMES'
4180       include 'COMMON.FFIELD'
4181       include 'COMMON.TORCNSTR'
4182       common /calcthet/ term1,term2,termm,diffak,ratak,
4183      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4184      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4185       double precision y(2),z(2)
4186       delta=0.02d0*pi
4187 c      time11=dexp(-2*time)
4188 c      time12=1.0d0
4189       etheta=0.0D0
4190 c      write (iout,*) "nres",nres
4191 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4192 c      write (iout,*) ithet_start,ithet_end
4193       do i=ithet_start,ithet_end
4194 C        if (itype(i-1).eq.ntyp1) cycle
4195         if (i.le.2) cycle
4196         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4197      &  .or.itype(i).eq.ntyp1) cycle
4198 C Zero the energy function and its derivative at 0 or pi.
4199         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4200         it=itype(i-1)
4201         ichir1=isign(1,itype(i-2))
4202         ichir2=isign(1,itype(i))
4203          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4204          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4205          if (itype(i-1).eq.10) then
4206           itype1=isign(10,itype(i-2))
4207           ichir11=isign(1,itype(i-2))
4208           ichir12=isign(1,itype(i-2))
4209           itype2=isign(10,itype(i))
4210           ichir21=isign(1,itype(i))
4211           ichir22=isign(1,itype(i))
4212          endif
4213          if (i.eq.3) then
4214           y(1)=0.0D0
4215           y(2)=0.0D0
4216           else
4217
4218         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4219 #ifdef OSF
4220           phii=phi(i)
4221 c          icrc=0
4222 c          call proc_proc(phii,icrc)
4223           if (icrc.eq.1) phii=150.0
4224 #else
4225           phii=phi(i)
4226 #endif
4227           y(1)=dcos(phii)
4228           y(2)=dsin(phii)
4229         else
4230           y(1)=0.0D0
4231           y(2)=0.0D0
4232         endif
4233         endif
4234         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4235 #ifdef OSF
4236           phii1=phi(i+1)
4237 c          icrc=0
4238 c          call proc_proc(phii1,icrc)
4239           if (icrc.eq.1) phii1=150.0
4240           phii1=pinorm(phii1)
4241           z(1)=cos(phii1)
4242 #else
4243           phii1=phi(i+1)
4244           z(1)=dcos(phii1)
4245 #endif
4246           z(2)=dsin(phii1)
4247         else
4248           z(1)=0.0D0
4249           z(2)=0.0D0
4250         endif
4251 C Calculate the "mean" value of theta from the part of the distribution
4252 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4253 C In following comments this theta will be referred to as t_c.
4254         thet_pred_mean=0.0d0
4255         do k=1,2
4256             athetk=athet(k,it,ichir1,ichir2)
4257             bthetk=bthet(k,it,ichir1,ichir2)
4258           if (it.eq.10) then
4259              athetk=athet(k,itype1,ichir11,ichir12)
4260              bthetk=bthet(k,itype2,ichir21,ichir22)
4261           endif
4262           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4263         enddo
4264 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4265         dthett=thet_pred_mean*ssd
4266         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4267 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4268 C Derivatives of the "mean" values in gamma1 and gamma2.
4269         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4270      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4271          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4272      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4273          if (it.eq.10) then
4274       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4275      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4276         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4277      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4278          endif
4279         if (theta(i).gt.pi-delta) then
4280           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4281      &         E_tc0)
4282           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4283           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4284           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4285      &        E_theta)
4286           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4287      &        E_tc)
4288         else if (theta(i).lt.delta) then
4289           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4290           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4291           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4292      &        E_theta)
4293           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4294           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4295      &        E_tc)
4296         else
4297           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4298      &        E_theta,E_tc)
4299         endif
4300         etheta=etheta+ethetai
4301 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4302 c     &      'ebend',i,ethetai,theta(i),itype(i)
4303 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4304 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4305         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4306         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4307         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4308 c 1215   continue
4309       enddo
4310       ethetacnstr=0.0d0
4311 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4312       do i=1,ntheta_constr
4313         itheta=itheta_constr(i)
4314         thetiii=theta(itheta)
4315         difi=pinorm(thetiii-theta_constr0(i))
4316         if (difi.gt.theta_drange(i)) then
4317           difi=difi-theta_drange(i)
4318           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4319           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4320      &    +for_thet_constr(i)*difi**3
4321         else if (difi.lt.-drange(i)) then
4322           difi=difi+drange(i)
4323           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4324           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4325      &    +for_thet_constr(i)*difi**3
4326         else
4327           difi=0.0
4328         endif
4329 C       if (energy_dec) then
4330 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4331 C     &    i,itheta,rad2deg*thetiii,
4332 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4333 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4334 C     &    gloc(itheta+nphi-2,icg)
4335 C        endif
4336       enddo
4337 C Ufff.... We've done all this!!!
4338       return
4339       end
4340 C---------------------------------------------------------------------------
4341       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4342      &     E_tc)
4343       implicit real*8 (a-h,o-z)
4344       include 'DIMENSIONS'
4345       include 'COMMON.LOCAL'
4346       include 'COMMON.IOUNITS'
4347       common /calcthet/ term1,term2,termm,diffak,ratak,
4348      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4349      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4350 C Calculate the contributions to both Gaussian lobes.
4351 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4352 C The "polynomial part" of the "standard deviation" of this part of
4353 C the distribution.
4354         sig=polthet(3,it)
4355         do j=2,0,-1
4356           sig=sig*thet_pred_mean+polthet(j,it)
4357         enddo
4358 C Derivative of the "interior part" of the "standard deviation of the"
4359 C gamma-dependent Gaussian lobe in t_c.
4360         sigtc=3*polthet(3,it)
4361         do j=2,1,-1
4362           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4363         enddo
4364         sigtc=sig*sigtc
4365 C Set the parameters of both Gaussian lobes of the distribution.
4366 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4367         fac=sig*sig+sigc0(it)
4368         sigcsq=fac+fac
4369         sigc=1.0D0/sigcsq
4370 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4371         sigsqtc=-4.0D0*sigcsq*sigtc
4372 c       print *,i,sig,sigtc,sigsqtc
4373 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4374         sigtc=-sigtc/(fac*fac)
4375 C Following variable is sigma(t_c)**(-2)
4376         sigcsq=sigcsq*sigcsq
4377         sig0i=sig0(it)
4378         sig0inv=1.0D0/sig0i**2
4379         delthec=thetai-thet_pred_mean
4380         delthe0=thetai-theta0i
4381         term1=-0.5D0*sigcsq*delthec*delthec
4382         term2=-0.5D0*sig0inv*delthe0*delthe0
4383 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4384 C NaNs in taking the logarithm. We extract the largest exponent which is added
4385 C to the energy (this being the log of the distribution) at the end of energy
4386 C term evaluation for this virtual-bond angle.
4387         if (term1.gt.term2) then
4388           termm=term1
4389           term2=dexp(term2-termm)
4390           term1=1.0d0
4391         else
4392           termm=term2
4393           term1=dexp(term1-termm)
4394           term2=1.0d0
4395         endif
4396 C The ratio between the gamma-independent and gamma-dependent lobes of
4397 C the distribution is a Gaussian function of thet_pred_mean too.
4398         diffak=gthet(2,it)-thet_pred_mean
4399         ratak=diffak/gthet(3,it)**2
4400         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4401 C Let's differentiate it in thet_pred_mean NOW.
4402         aktc=ak*ratak
4403 C Now put together the distribution terms to make complete distribution.
4404         termexp=term1+ak*term2
4405         termpre=sigc+ak*sig0i
4406 C Contribution of the bending energy from this theta is just the -log of
4407 C the sum of the contributions from the two lobes and the pre-exponential
4408 C factor. Simple enough, isn't it?
4409         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4410 C NOW the derivatives!!!
4411 C 6/6/97 Take into account the deformation.
4412         E_theta=(delthec*sigcsq*term1
4413      &       +ak*delthe0*sig0inv*term2)/termexp
4414         E_tc=((sigtc+aktc*sig0i)/termpre
4415      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4416      &       aktc*term2)/termexp)
4417       return
4418       end
4419 c-----------------------------------------------------------------------------
4420       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4421       implicit real*8 (a-h,o-z)
4422       include 'DIMENSIONS'
4423       include 'COMMON.LOCAL'
4424       include 'COMMON.IOUNITS'
4425       common /calcthet/ term1,term2,termm,diffak,ratak,
4426      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4427      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4428       delthec=thetai-thet_pred_mean
4429       delthe0=thetai-theta0i
4430 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4431       t3 = thetai-thet_pred_mean
4432       t6 = t3**2
4433       t9 = term1
4434       t12 = t3*sigcsq
4435       t14 = t12+t6*sigsqtc
4436       t16 = 1.0d0
4437       t21 = thetai-theta0i
4438       t23 = t21**2
4439       t26 = term2
4440       t27 = t21*t26
4441       t32 = termexp
4442       t40 = t32**2
4443       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4444      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4445      & *(-t12*t9-ak*sig0inv*t27)
4446       return
4447       end
4448 #else
4449 C--------------------------------------------------------------------------
4450       subroutine ebend(etheta,ethetacnstr)
4451 C
4452 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4453 C angles gamma and its derivatives in consecutive thetas and gammas.
4454 C ab initio-derived potentials from
4455 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4456 C
4457       implicit real*8 (a-h,o-z)
4458       include 'DIMENSIONS'
4459       include 'DIMENSIONS.ZSCOPT'
4460       include 'COMMON.LOCAL'
4461       include 'COMMON.GEO'
4462       include 'COMMON.INTERACT'
4463       include 'COMMON.DERIV'
4464       include 'COMMON.VAR'
4465       include 'COMMON.CHAIN'
4466       include 'COMMON.IOUNITS'
4467       include 'COMMON.NAMES'
4468       include 'COMMON.FFIELD'
4469       include 'COMMON.CONTROL'
4470       include 'COMMON.TORCNSTR'
4471       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4472      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4473      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4474      & sinph1ph2(maxdouble,maxdouble)
4475       logical lprn /.false./, lprn1 /.false./
4476       etheta=0.0D0
4477 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4478       do i=ithet_start,ithet_end
4479 C         if (i.eq.2) cycle
4480 C        if (itype(i-1).eq.ntyp1) cycle
4481         if (i.le.2) cycle
4482         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4483      &  .or.itype(i).eq.ntyp1) cycle
4484         if (iabs(itype(i+1)).eq.20) iblock=2
4485         if (iabs(itype(i+1)).ne.20) iblock=1
4486         dethetai=0.0d0
4487         dephii=0.0d0
4488         dephii1=0.0d0
4489         theti2=0.5d0*theta(i)
4490         ityp2=ithetyp((itype(i-1)))
4491         do k=1,nntheterm
4492           coskt(k)=dcos(k*theti2)
4493           sinkt(k)=dsin(k*theti2)
4494         enddo
4495         if (i.eq.3) then
4496           phii=0.0d0
4497           ityp1=nthetyp+1
4498           do k=1,nsingle
4499             cosph1(k)=0.0d0
4500             sinph1(k)=0.0d0
4501           enddo
4502         else
4503         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4504 #ifdef OSF
4505           phii=phi(i)
4506           if (phii.ne.phii) phii=150.0
4507 #else
4508           phii=phi(i)
4509 #endif
4510           ityp1=ithetyp((itype(i-2)))
4511           do k=1,nsingle
4512             cosph1(k)=dcos(k*phii)
4513             sinph1(k)=dsin(k*phii)
4514           enddo
4515         else
4516           phii=0.0d0
4517 c          ityp1=nthetyp+1
4518           do k=1,nsingle
4519             ityp1=ithetyp((itype(i-2)))
4520             cosph1(k)=0.0d0
4521             sinph1(k)=0.0d0
4522           enddo
4523         endif
4524         endif
4525         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4526 #ifdef OSF
4527           phii1=phi(i+1)
4528           if (phii1.ne.phii1) phii1=150.0
4529           phii1=pinorm(phii1)
4530 #else
4531           phii1=phi(i+1)
4532 #endif
4533           ityp3=ithetyp((itype(i)))
4534           do k=1,nsingle
4535             cosph2(k)=dcos(k*phii1)
4536             sinph2(k)=dsin(k*phii1)
4537           enddo
4538         else
4539           phii1=0.0d0
4540 c          ityp3=nthetyp+1
4541           ityp3=ithetyp((itype(i)))
4542           do k=1,nsingle
4543             cosph2(k)=0.0d0
4544             sinph2(k)=0.0d0
4545           enddo
4546         endif
4547 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4548 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4549 c        call flush(iout)
4550         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4551         do k=1,ndouble
4552           do l=1,k-1
4553             ccl=cosph1(l)*cosph2(k-l)
4554             ssl=sinph1(l)*sinph2(k-l)
4555             scl=sinph1(l)*cosph2(k-l)
4556             csl=cosph1(l)*sinph2(k-l)
4557             cosph1ph2(l,k)=ccl-ssl
4558             cosph1ph2(k,l)=ccl+ssl
4559             sinph1ph2(l,k)=scl+csl
4560             sinph1ph2(k,l)=scl-csl
4561           enddo
4562         enddo
4563         if (lprn) then
4564         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4565      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4566         write (iout,*) "coskt and sinkt"
4567         do k=1,nntheterm
4568           write (iout,*) k,coskt(k),sinkt(k)
4569         enddo
4570         endif
4571         do k=1,ntheterm
4572           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4573           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4574      &      *coskt(k)
4575           if (lprn)
4576      &    write (iout,*) "k",k,"
4577      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4578      &     " ethetai",ethetai
4579         enddo
4580         if (lprn) then
4581         write (iout,*) "cosph and sinph"
4582         do k=1,nsingle
4583           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4584         enddo
4585         write (iout,*) "cosph1ph2 and sinph2ph2"
4586         do k=2,ndouble
4587           do l=1,k-1
4588             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4589      &         sinph1ph2(l,k),sinph1ph2(k,l)
4590           enddo
4591         enddo
4592         write(iout,*) "ethetai",ethetai
4593         endif
4594         do m=1,ntheterm2
4595           do k=1,nsingle
4596             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4597      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4598      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4599      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4600             ethetai=ethetai+sinkt(m)*aux
4601             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4602             dephii=dephii+k*sinkt(m)*(
4603      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4604      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4605             dephii1=dephii1+k*sinkt(m)*(
4606      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4607      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4608             if (lprn)
4609      &      write (iout,*) "m",m," k",k," bbthet",
4610      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4611      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4612      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4613      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4614           enddo
4615         enddo
4616         if (lprn)
4617      &  write(iout,*) "ethetai",ethetai
4618         do m=1,ntheterm3
4619           do k=2,ndouble
4620             do l=1,k-1
4621               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4622      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4623      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4624      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4625               ethetai=ethetai+sinkt(m)*aux
4626               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4627               dephii=dephii+l*sinkt(m)*(
4628      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4629      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4630      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4631      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4632               dephii1=dephii1+(k-l)*sinkt(m)*(
4633      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4634      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4635      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4636      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4637               if (lprn) then
4638               write (iout,*) "m",m," k",k," l",l," ffthet",
4639      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4640      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4641      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4642      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4643      &            " ethetai",ethetai
4644               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4645      &            cosph1ph2(k,l)*sinkt(m),
4646      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4647               endif
4648             enddo
4649           enddo
4650         enddo
4651 10      continue
4652         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4653      &   i,theta(i)*rad2deg,phii*rad2deg,
4654      &   phii1*rad2deg,ethetai
4655         etheta=etheta+ethetai
4656         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4657         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4658 c        gloc(nphi+i-2,icg)=wang*dethetai
4659         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4660       enddo
4661 C now constrains
4662       ethetacnstr=0.0d0
4663 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4664       do i=1,ntheta_constr
4665         itheta=itheta_constr(i)
4666         thetiii=theta(itheta)
4667         difi=pinorm(thetiii-theta_constr0(i))
4668         if (difi.gt.theta_drange(i)) then
4669           difi=difi-theta_drange(i)
4670           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4671           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4672      &    +for_thet_constr(i)*difi**3
4673         else if (difi.lt.-drange(i)) then
4674           difi=difi+drange(i)
4675           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4676           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4677      &    +for_thet_constr(i)*difi**3
4678         else
4679           difi=0.0
4680         endif
4681 C       if (energy_dec) then
4682 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4683 C     &    i,itheta,rad2deg*thetiii,
4684 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4685 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4686 C     &    gloc(itheta+nphi-2,icg)
4687 C        endif
4688       enddo
4689       return
4690       end
4691 #endif
4692 #ifdef CRYST_SC
4693 c-----------------------------------------------------------------------------
4694       subroutine esc(escloc)
4695 C Calculate the local energy of a side chain and its derivatives in the
4696 C corresponding virtual-bond valence angles THETA and the spherical angles
4697 C ALPHA and OMEGA.
4698       implicit real*8 (a-h,o-z)
4699       include 'DIMENSIONS'
4700       include 'DIMENSIONS.ZSCOPT'
4701       include 'COMMON.GEO'
4702       include 'COMMON.LOCAL'
4703       include 'COMMON.VAR'
4704       include 'COMMON.INTERACT'
4705       include 'COMMON.DERIV'
4706       include 'COMMON.CHAIN'
4707       include 'COMMON.IOUNITS'
4708       include 'COMMON.NAMES'
4709       include 'COMMON.FFIELD'
4710       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4711      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4712       common /sccalc/ time11,time12,time112,theti,it,nlobit
4713       delta=0.02d0*pi
4714       escloc=0.0D0
4715 C      write (iout,*) 'ESC'
4716       do i=loc_start,loc_end
4717         it=itype(i)
4718         if (it.eq.ntyp1) cycle
4719         if (it.eq.10) goto 1
4720         nlobit=nlob(iabs(it))
4721 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4722 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4723         theti=theta(i+1)-pipol
4724         x(1)=dtan(theti)
4725         x(2)=alph(i)
4726         x(3)=omeg(i)
4727 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4728
4729         if (x(2).gt.pi-delta) then
4730           xtemp(1)=x(1)
4731           xtemp(2)=pi-delta
4732           xtemp(3)=x(3)
4733           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4734           xtemp(2)=pi
4735           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4736           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4737      &        escloci,dersc(2))
4738           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4739      &        ddersc0(1),dersc(1))
4740           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4741      &        ddersc0(3),dersc(3))
4742           xtemp(2)=pi-delta
4743           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4744           xtemp(2)=pi
4745           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4746           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4747      &            dersc0(2),esclocbi,dersc02)
4748           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4749      &            dersc12,dersc01)
4750           call splinthet(x(2),0.5d0*delta,ss,ssd)
4751           dersc0(1)=dersc01
4752           dersc0(2)=dersc02
4753           dersc0(3)=0.0d0
4754           do k=1,3
4755             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4756           enddo
4757           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4758           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4759      &             esclocbi,ss,ssd
4760           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4761 c         escloci=esclocbi
4762 c         write (iout,*) escloci
4763         else if (x(2).lt.delta) then
4764           xtemp(1)=x(1)
4765           xtemp(2)=delta
4766           xtemp(3)=x(3)
4767           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4768           xtemp(2)=0.0d0
4769           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4770           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4771      &        escloci,dersc(2))
4772           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4773      &        ddersc0(1),dersc(1))
4774           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4775      &        ddersc0(3),dersc(3))
4776           xtemp(2)=delta
4777           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4778           xtemp(2)=0.0d0
4779           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4780           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4781      &            dersc0(2),esclocbi,dersc02)
4782           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4783      &            dersc12,dersc01)
4784           dersc0(1)=dersc01
4785           dersc0(2)=dersc02
4786           dersc0(3)=0.0d0
4787           call splinthet(x(2),0.5d0*delta,ss,ssd)
4788           do k=1,3
4789             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4790           enddo
4791           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4792 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4793 c     &             esclocbi,ss,ssd
4794           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4795 C         write (iout,*) 'i=',i, escloci
4796         else
4797           call enesc(x,escloci,dersc,ddummy,.false.)
4798         endif
4799
4800         escloc=escloc+escloci
4801 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4802             write (iout,'(a6,i5,0pf7.3)')
4803      &     'escloc',i,escloci
4804
4805         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4806      &   wscloc*dersc(1)
4807         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4808         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4809     1   continue
4810       enddo
4811       return
4812       end
4813 C---------------------------------------------------------------------------
4814       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4815       implicit real*8 (a-h,o-z)
4816       include 'DIMENSIONS'
4817       include 'COMMON.GEO'
4818       include 'COMMON.LOCAL'
4819       include 'COMMON.IOUNITS'
4820       common /sccalc/ time11,time12,time112,theti,it,nlobit
4821       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4822       double precision contr(maxlob,-1:1)
4823       logical mixed
4824 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4825         escloc_i=0.0D0
4826         do j=1,3
4827           dersc(j)=0.0D0
4828           if (mixed) ddersc(j)=0.0d0
4829         enddo
4830         x3=x(3)
4831
4832 C Because of periodicity of the dependence of the SC energy in omega we have
4833 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4834 C To avoid underflows, first compute & store the exponents.
4835
4836         do iii=-1,1
4837
4838           x(3)=x3+iii*dwapi
4839
4840           do j=1,nlobit
4841             do k=1,3
4842               z(k)=x(k)-censc(k,j,it)
4843             enddo
4844             do k=1,3
4845               Axk=0.0D0
4846               do l=1,3
4847                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4848               enddo
4849               Ax(k,j,iii)=Axk
4850             enddo
4851             expfac=0.0D0
4852             do k=1,3
4853               expfac=expfac+Ax(k,j,iii)*z(k)
4854             enddo
4855             contr(j,iii)=expfac
4856           enddo ! j
4857
4858         enddo ! iii
4859
4860         x(3)=x3
4861 C As in the case of ebend, we want to avoid underflows in exponentiation and
4862 C subsequent NaNs and INFs in energy calculation.
4863 C Find the largest exponent
4864         emin=contr(1,-1)
4865         do iii=-1,1
4866           do j=1,nlobit
4867             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4868           enddo
4869         enddo
4870         emin=0.5D0*emin
4871 cd      print *,'it=',it,' emin=',emin
4872
4873 C Compute the contribution to SC energy and derivatives
4874         do iii=-1,1
4875
4876           do j=1,nlobit
4877             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4878 cd          print *,'j=',j,' expfac=',expfac
4879             escloc_i=escloc_i+expfac
4880             do k=1,3
4881               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4882             enddo
4883             if (mixed) then
4884               do k=1,3,2
4885                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4886      &            +gaussc(k,2,j,it))*expfac
4887               enddo
4888             endif
4889           enddo
4890
4891         enddo ! iii
4892
4893         dersc(1)=dersc(1)/cos(theti)**2
4894         ddersc(1)=ddersc(1)/cos(theti)**2
4895         ddersc(3)=ddersc(3)
4896
4897         escloci=-(dlog(escloc_i)-emin)
4898         do j=1,3
4899           dersc(j)=dersc(j)/escloc_i
4900         enddo
4901         if (mixed) then
4902           do j=1,3,2
4903             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4904           enddo
4905         endif
4906       return
4907       end
4908 C------------------------------------------------------------------------------
4909       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4910       implicit real*8 (a-h,o-z)
4911       include 'DIMENSIONS'
4912       include 'COMMON.GEO'
4913       include 'COMMON.LOCAL'
4914       include 'COMMON.IOUNITS'
4915       common /sccalc/ time11,time12,time112,theti,it,nlobit
4916       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4917       double precision contr(maxlob)
4918       logical mixed
4919
4920       escloc_i=0.0D0
4921
4922       do j=1,3
4923         dersc(j)=0.0D0
4924       enddo
4925
4926       do j=1,nlobit
4927         do k=1,2
4928           z(k)=x(k)-censc(k,j,it)
4929         enddo
4930         z(3)=dwapi
4931         do k=1,3
4932           Axk=0.0D0
4933           do l=1,3
4934             Axk=Axk+gaussc(l,k,j,it)*z(l)
4935           enddo
4936           Ax(k,j)=Axk
4937         enddo
4938         expfac=0.0D0
4939         do k=1,3
4940           expfac=expfac+Ax(k,j)*z(k)
4941         enddo
4942         contr(j)=expfac
4943       enddo ! j
4944
4945 C As in the case of ebend, we want to avoid underflows in exponentiation and
4946 C subsequent NaNs and INFs in energy calculation.
4947 C Find the largest exponent
4948       emin=contr(1)
4949       do j=1,nlobit
4950         if (emin.gt.contr(j)) emin=contr(j)
4951       enddo
4952       emin=0.5D0*emin
4953
4954 C Compute the contribution to SC energy and derivatives
4955
4956       dersc12=0.0d0
4957       do j=1,nlobit
4958         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4959         escloc_i=escloc_i+expfac
4960         do k=1,2
4961           dersc(k)=dersc(k)+Ax(k,j)*expfac
4962         enddo
4963         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4964      &            +gaussc(1,2,j,it))*expfac
4965         dersc(3)=0.0d0
4966       enddo
4967
4968       dersc(1)=dersc(1)/cos(theti)**2
4969       dersc12=dersc12/cos(theti)**2
4970       escloci=-(dlog(escloc_i)-emin)
4971       do j=1,2
4972         dersc(j)=dersc(j)/escloc_i
4973       enddo
4974       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4975       return
4976       end
4977 #else
4978 c----------------------------------------------------------------------------------
4979       subroutine esc(escloc)
4980 C Calculate the local energy of a side chain and its derivatives in the
4981 C corresponding virtual-bond valence angles THETA and the spherical angles
4982 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4983 C added by Urszula Kozlowska. 07/11/2007
4984 C
4985       implicit real*8 (a-h,o-z)
4986       include 'DIMENSIONS'
4987       include 'DIMENSIONS.ZSCOPT'
4988       include 'COMMON.GEO'
4989       include 'COMMON.LOCAL'
4990       include 'COMMON.VAR'
4991       include 'COMMON.SCROT'
4992       include 'COMMON.INTERACT'
4993       include 'COMMON.DERIV'
4994       include 'COMMON.CHAIN'
4995       include 'COMMON.IOUNITS'
4996       include 'COMMON.NAMES'
4997       include 'COMMON.FFIELD'
4998       include 'COMMON.CONTROL'
4999       include 'COMMON.VECTORS'
5000       double precision x_prime(3),y_prime(3),z_prime(3)
5001      &    , sumene,dsc_i,dp2_i,x(65),
5002      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5003      &    de_dxx,de_dyy,de_dzz,de_dt
5004       double precision s1_t,s1_6_t,s2_t,s2_6_t
5005       double precision
5006      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5007      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5008      & dt_dCi(3),dt_dCi1(3)
5009       common /sccalc/ time11,time12,time112,theti,it,nlobit
5010       delta=0.02d0*pi
5011       escloc=0.0D0
5012       do i=loc_start,loc_end
5013         if (itype(i).eq.ntyp1) cycle
5014         costtab(i+1) =dcos(theta(i+1))
5015         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5016         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5017         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5018         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5019         cosfac=dsqrt(cosfac2)
5020         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5021         sinfac=dsqrt(sinfac2)
5022         it=iabs(itype(i))
5023         if (it.eq.10) goto 1
5024 c
5025 C  Compute the axes of tghe local cartesian coordinates system; store in
5026 c   x_prime, y_prime and z_prime
5027 c
5028         do j=1,3
5029           x_prime(j) = 0.00
5030           y_prime(j) = 0.00
5031           z_prime(j) = 0.00
5032         enddo
5033 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5034 C     &   dc_norm(3,i+nres)
5035         do j = 1,3
5036           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5037           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5038         enddo
5039         do j = 1,3
5040           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5041         enddo
5042 c       write (2,*) "i",i
5043 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5044 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5045 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5046 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5047 c      & " xy",scalar(x_prime(1),y_prime(1)),
5048 c      & " xz",scalar(x_prime(1),z_prime(1)),
5049 c      & " yy",scalar(y_prime(1),y_prime(1)),
5050 c      & " yz",scalar(y_prime(1),z_prime(1)),
5051 c      & " zz",scalar(z_prime(1),z_prime(1))
5052 c
5053 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5054 C to local coordinate system. Store in xx, yy, zz.
5055 c
5056         xx=0.0d0
5057         yy=0.0d0
5058         zz=0.0d0
5059         do j = 1,3
5060           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5061           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5062           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5063         enddo
5064
5065         xxtab(i)=xx
5066         yytab(i)=yy
5067         zztab(i)=zz
5068 C
5069 C Compute the energy of the ith side cbain
5070 C
5071 c        write (2,*) "xx",xx," yy",yy," zz",zz
5072         it=iabs(itype(i))
5073         do j = 1,65
5074           x(j) = sc_parmin(j,it)
5075         enddo
5076 #ifdef CHECK_COORD
5077 Cc diagnostics - remove later
5078         xx1 = dcos(alph(2))
5079         yy1 = dsin(alph(2))*dcos(omeg(2))
5080         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5081         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5082      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5083      &    xx1,yy1,zz1
5084 C,"  --- ", xx_w,yy_w,zz_w
5085 c end diagnostics
5086 #endif
5087         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5088      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5089      &   + x(10)*yy*zz
5090         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5091      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5092      & + x(20)*yy*zz
5093         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5094      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5095      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5096      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5097      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5098      &  +x(40)*xx*yy*zz
5099         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5100      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5101      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5102      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5103      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5104      &  +x(60)*xx*yy*zz
5105         dsc_i   = 0.743d0+x(61)
5106         dp2_i   = 1.9d0+x(62)
5107         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5108      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5109         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5110      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5111         s1=(1+x(63))/(0.1d0 + dscp1)
5112         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5113         s2=(1+x(65))/(0.1d0 + dscp2)
5114         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5115         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5116      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5117 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5118 c     &   sumene4,
5119 c     &   dscp1,dscp2,sumene
5120 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5121         escloc = escloc + sumene
5122 c        write (2,*) "escloc",escloc
5123 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5124 c     &  zz,xx,yy
5125         if (.not. calc_grad) goto 1
5126 #ifdef DEBUG
5127 C
5128 C This section to check the numerical derivatives of the energy of ith side
5129 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5130 C #define DEBUG in the code to turn it on.
5131 C
5132         write (2,*) "sumene               =",sumene
5133         aincr=1.0d-7
5134         xxsave=xx
5135         xx=xx+aincr
5136         write (2,*) xx,yy,zz
5137         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5138         de_dxx_num=(sumenep-sumene)/aincr
5139         xx=xxsave
5140         write (2,*) "xx+ sumene from enesc=",sumenep
5141         yysave=yy
5142         yy=yy+aincr
5143         write (2,*) xx,yy,zz
5144         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5145         de_dyy_num=(sumenep-sumene)/aincr
5146         yy=yysave
5147         write (2,*) "yy+ sumene from enesc=",sumenep
5148         zzsave=zz
5149         zz=zz+aincr
5150         write (2,*) xx,yy,zz
5151         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5152         de_dzz_num=(sumenep-sumene)/aincr
5153         zz=zzsave
5154         write (2,*) "zz+ sumene from enesc=",sumenep
5155         costsave=cost2tab(i+1)
5156         sintsave=sint2tab(i+1)
5157         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5158         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5159         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5160         de_dt_num=(sumenep-sumene)/aincr
5161         write (2,*) " t+ sumene from enesc=",sumenep
5162         cost2tab(i+1)=costsave
5163         sint2tab(i+1)=sintsave
5164 C End of diagnostics section.
5165 #endif
5166 C
5167 C Compute the gradient of esc
5168 C
5169         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5170         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5171         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5172         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5173         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5174         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5175         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5176         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5177         pom1=(sumene3*sint2tab(i+1)+sumene1)
5178      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5179         pom2=(sumene4*cost2tab(i+1)+sumene2)
5180      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5181         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5182         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5183      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5184      &  +x(40)*yy*zz
5185         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5186         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5187      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5188      &  +x(60)*yy*zz
5189         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5190      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5191      &        +(pom1+pom2)*pom_dx
5192 #ifdef DEBUG
5193         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5194 #endif
5195 C
5196         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5197         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5198      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5199      &  +x(40)*xx*zz
5200         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5201         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5202      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5203      &  +x(59)*zz**2 +x(60)*xx*zz
5204         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5205      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5206      &        +(pom1-pom2)*pom_dy
5207 #ifdef DEBUG
5208         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5209 #endif
5210 C
5211         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5212      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5213      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5214      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5215      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5216      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5217      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5218      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5219 #ifdef DEBUG
5220         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5221 #endif
5222 C
5223         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5224      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5225      &  +pom1*pom_dt1+pom2*pom_dt2
5226 #ifdef DEBUG
5227         write(2,*), "de_dt = ", de_dt,de_dt_num
5228 #endif
5229 c
5230 C
5231        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5232        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5233        cosfac2xx=cosfac2*xx
5234        sinfac2yy=sinfac2*yy
5235        do k = 1,3
5236          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5237      &      vbld_inv(i+1)
5238          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5239      &      vbld_inv(i)
5240          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5241          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5242 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5243 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5244 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5245 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5246          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5247          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5248          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5249          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5250          dZZ_Ci1(k)=0.0d0
5251          dZZ_Ci(k)=0.0d0
5252          do j=1,3
5253            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5254      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5255            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5256      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5257          enddo
5258
5259          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5260          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5261          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5262 c
5263          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5264          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5265        enddo
5266
5267        do k=1,3
5268          dXX_Ctab(k,i)=dXX_Ci(k)
5269          dXX_C1tab(k,i)=dXX_Ci1(k)
5270          dYY_Ctab(k,i)=dYY_Ci(k)
5271          dYY_C1tab(k,i)=dYY_Ci1(k)
5272          dZZ_Ctab(k,i)=dZZ_Ci(k)
5273          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5274          dXX_XYZtab(k,i)=dXX_XYZ(k)
5275          dYY_XYZtab(k,i)=dYY_XYZ(k)
5276          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5277        enddo
5278
5279        do k = 1,3
5280 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5281 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5282 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5283 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5284 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5285 c     &    dt_dci(k)
5286 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5287 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5288          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5289      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5290          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5291      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5292          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5293      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5294        enddo
5295 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5296 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5297
5298 C to check gradient call subroutine check_grad
5299
5300     1 continue
5301       enddo
5302       return
5303       end
5304 #endif
5305 c------------------------------------------------------------------------------
5306       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5307 C
5308 C This procedure calculates two-body contact function g(rij) and its derivative:
5309 C
5310 C           eps0ij                                     !       x < -1
5311 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5312 C            0                                         !       x > 1
5313 C
5314 C where x=(rij-r0ij)/delta
5315 C
5316 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5317 C
5318       implicit none
5319       double precision rij,r0ij,eps0ij,fcont,fprimcont
5320       double precision x,x2,x4,delta
5321 c     delta=0.02D0*r0ij
5322 c      delta=0.2D0*r0ij
5323       x=(rij-r0ij)/delta
5324       if (x.lt.-1.0D0) then
5325         fcont=eps0ij
5326         fprimcont=0.0D0
5327       else if (x.le.1.0D0) then
5328         x2=x*x
5329         x4=x2*x2
5330         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5331         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5332       else
5333         fcont=0.0D0
5334         fprimcont=0.0D0
5335       endif
5336       return
5337       end
5338 c------------------------------------------------------------------------------
5339       subroutine splinthet(theti,delta,ss,ssder)
5340       implicit real*8 (a-h,o-z)
5341       include 'DIMENSIONS'
5342       include 'DIMENSIONS.ZSCOPT'
5343       include 'COMMON.VAR'
5344       include 'COMMON.GEO'
5345       thetup=pi-delta
5346       thetlow=delta
5347       if (theti.gt.pipol) then
5348         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5349       else
5350         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5351         ssder=-ssder
5352       endif
5353       return
5354       end
5355 c------------------------------------------------------------------------------
5356       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5357       implicit none
5358       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5359       double precision ksi,ksi2,ksi3,a1,a2,a3
5360       a1=fprim0*delta/(f1-f0)
5361       a2=3.0d0-2.0d0*a1
5362       a3=a1-2.0d0
5363       ksi=(x-x0)/delta
5364       ksi2=ksi*ksi
5365       ksi3=ksi2*ksi
5366       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5367       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5368       return
5369       end
5370 c------------------------------------------------------------------------------
5371       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5372       implicit none
5373       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5374       double precision ksi,ksi2,ksi3,a1,a2,a3
5375       ksi=(x-x0)/delta
5376       ksi2=ksi*ksi
5377       ksi3=ksi2*ksi
5378       a1=fprim0x*delta
5379       a2=3*(f1x-f0x)-2*fprim0x*delta
5380       a3=fprim0x*delta-2*(f1x-f0x)
5381       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5382       return
5383       end
5384 C-----------------------------------------------------------------------------
5385 #ifdef CRYST_TOR
5386 C-----------------------------------------------------------------------------
5387       subroutine etor(etors,edihcnstr,fact)
5388       implicit real*8 (a-h,o-z)
5389       include 'DIMENSIONS'
5390       include 'DIMENSIONS.ZSCOPT'
5391       include 'COMMON.VAR'
5392       include 'COMMON.GEO'
5393       include 'COMMON.LOCAL'
5394       include 'COMMON.TORSION'
5395       include 'COMMON.INTERACT'
5396       include 'COMMON.DERIV'
5397       include 'COMMON.CHAIN'
5398       include 'COMMON.NAMES'
5399       include 'COMMON.IOUNITS'
5400       include 'COMMON.FFIELD'
5401       include 'COMMON.TORCNSTR'
5402       logical lprn
5403 C Set lprn=.true. for debugging
5404       lprn=.false.
5405 c      lprn=.true.
5406       etors=0.0D0
5407       do i=iphi_start,iphi_end
5408         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5409      &      .or. itype(i).eq.ntyp1) cycle
5410         itori=itortyp(itype(i-2))
5411         itori1=itortyp(itype(i-1))
5412         phii=phi(i)
5413         gloci=0.0D0
5414 C Proline-Proline pair is a special case...
5415         if (itori.eq.3 .and. itori1.eq.3) then
5416           if (phii.gt.-dwapi3) then
5417             cosphi=dcos(3*phii)
5418             fac=1.0D0/(1.0D0-cosphi)
5419             etorsi=v1(1,3,3)*fac
5420             etorsi=etorsi+etorsi
5421             etors=etors+etorsi-v1(1,3,3)
5422             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5423           endif
5424           do j=1,3
5425             v1ij=v1(j+1,itori,itori1)
5426             v2ij=v2(j+1,itori,itori1)
5427             cosphi=dcos(j*phii)
5428             sinphi=dsin(j*phii)
5429             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5430             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5431           enddo
5432         else
5433           do j=1,nterm_old
5434             v1ij=v1(j,itori,itori1)
5435             v2ij=v2(j,itori,itori1)
5436             cosphi=dcos(j*phii)
5437             sinphi=dsin(j*phii)
5438             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5439             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5440           enddo
5441         endif
5442         if (lprn)
5443      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5444      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5445      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5446         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5447 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5448       enddo
5449 ! 6/20/98 - dihedral angle constraints
5450       edihcnstr=0.0d0
5451       do i=1,ndih_constr
5452         itori=idih_constr(i)
5453         phii=phi(itori)
5454         difi=phii-phi0(i)
5455         if (difi.gt.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         else if (difi.lt.-drange(i)) then
5460           difi=difi+drange(i)
5461           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5462           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5463         endif
5464 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5465 C     &    i,itori,rad2deg*phii,
5466 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5467       enddo
5468 !      write (iout,*) 'edihcnstr',edihcnstr
5469       return
5470       end
5471 c------------------------------------------------------------------------------
5472 #else
5473       subroutine etor(etors,edihcnstr,fact)
5474       implicit real*8 (a-h,o-z)
5475       include 'DIMENSIONS'
5476       include 'DIMENSIONS.ZSCOPT'
5477       include 'COMMON.VAR'
5478       include 'COMMON.GEO'
5479       include 'COMMON.LOCAL'
5480       include 'COMMON.TORSION'
5481       include 'COMMON.INTERACT'
5482       include 'COMMON.DERIV'
5483       include 'COMMON.CHAIN'
5484       include 'COMMON.NAMES'
5485       include 'COMMON.IOUNITS'
5486       include 'COMMON.FFIELD'
5487       include 'COMMON.TORCNSTR'
5488       logical lprn
5489 C Set lprn=.true. for debugging
5490       lprn=.false.
5491 c      lprn=.true.
5492       etors=0.0D0
5493       do i=iphi_start,iphi_end
5494         if (i.le.2) cycle
5495         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5496      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5497 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5498 C     &       .or. itype(i).eq.ntyp1) cycle
5499         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5500          if (iabs(itype(i)).eq.20) then
5501          iblock=2
5502          else
5503          iblock=1
5504          endif
5505         itori=itortyp(itype(i-2))
5506         itori1=itortyp(itype(i-1))
5507         phii=phi(i)
5508         gloci=0.0D0
5509 C Regular cosine and sine terms
5510         do j=1,nterm(itori,itori1,iblock)
5511           v1ij=v1(j,itori,itori1,iblock)
5512           v2ij=v2(j,itori,itori1,iblock)
5513           cosphi=dcos(j*phii)
5514           sinphi=dsin(j*phii)
5515           etors=etors+v1ij*cosphi+v2ij*sinphi
5516           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5517         enddo
5518 C Lorentz terms
5519 C                         v1
5520 C  E = SUM ----------------------------------- - v1
5521 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5522 C
5523         cosphi=dcos(0.5d0*phii)
5524         sinphi=dsin(0.5d0*phii)
5525         do j=1,nlor(itori,itori1,iblock)
5526           vl1ij=vlor1(j,itori,itori1)
5527           vl2ij=vlor2(j,itori,itori1)
5528           vl3ij=vlor3(j,itori,itori1)
5529           pom=vl2ij*cosphi+vl3ij*sinphi
5530           pom1=1.0d0/(pom*pom+1.0d0)
5531           etors=etors+vl1ij*pom1
5532 c          if (energy_dec) etors_ii=etors_ii+
5533 c     &                vl1ij*pom1
5534           pom=-pom*pom1*pom1
5535           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5536         enddo
5537 C Subtract the constant term
5538         etors=etors-v0(itori,itori1,iblock)
5539         if (lprn)
5540      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5541      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5542      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5543         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5544 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5545  1215   continue
5546       enddo
5547 ! 6/20/98 - dihedral angle constraints
5548       edihcnstr=0.0d0
5549       do i=1,ndih_constr
5550         itori=idih_constr(i)
5551         phii=phi(itori)
5552         difi=pinorm(phii-phi0(i))
5553         edihi=0.0d0
5554         if (difi.gt.drange(i)) then
5555           difi=difi-drange(i)
5556           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5557           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5558           edihi=0.25d0*ftors(i)*difi**4
5559         else if (difi.lt.-drange(i)) then
5560           difi=difi+drange(i)
5561           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5562           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5563           edihi=0.25d0*ftors(i)*difi**4
5564         else
5565           difi=0.0d0
5566         endif
5567         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5568      &    i,itori,rad2deg*phii,
5569      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5570 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5571 c     &    drange(i),edihi
5572 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5573 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5574       enddo
5575 !      write (iout,*) 'edihcnstr',edihcnstr
5576       return
5577       end
5578 c----------------------------------------------------------------------------
5579       subroutine etor_d(etors_d,fact2)
5580 C 6/23/01 Compute double torsional energy
5581       implicit real*8 (a-h,o-z)
5582       include 'DIMENSIONS'
5583       include 'DIMENSIONS.ZSCOPT'
5584       include 'COMMON.VAR'
5585       include 'COMMON.GEO'
5586       include 'COMMON.LOCAL'
5587       include 'COMMON.TORSION'
5588       include 'COMMON.INTERACT'
5589       include 'COMMON.DERIV'
5590       include 'COMMON.CHAIN'
5591       include 'COMMON.NAMES'
5592       include 'COMMON.IOUNITS'
5593       include 'COMMON.FFIELD'
5594       include 'COMMON.TORCNSTR'
5595       logical lprn
5596 C Set lprn=.true. for debugging
5597       lprn=.false.
5598 c     lprn=.true.
5599       etors_d=0.0D0
5600       do i=iphi_start,iphi_end-1
5601         if (i.le.3) cycle
5602 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5603 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5604          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5605      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5606      &  (itype(i+1).eq.ntyp1)) cycle
5607         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5608      &     goto 1215
5609         itori=itortyp(itype(i-2))
5610         itori1=itortyp(itype(i-1))
5611         itori2=itortyp(itype(i))
5612         phii=phi(i)
5613         phii1=phi(i+1)
5614         gloci1=0.0D0
5615         gloci2=0.0D0
5616         iblock=1
5617         if (iabs(itype(i+1)).eq.20) iblock=2
5618 C Regular cosine and sine terms
5619         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5620           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5621           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5622           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5623           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5624           cosphi1=dcos(j*phii)
5625           sinphi1=dsin(j*phii)
5626           cosphi2=dcos(j*phii1)
5627           sinphi2=dsin(j*phii1)
5628           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5629      &     v2cij*cosphi2+v2sij*sinphi2
5630           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5631           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5632         enddo
5633         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5634           do l=1,k-1
5635             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5636             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5637             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5638             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5639             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5640             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5641             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5642             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5643             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5644      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5645             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5646      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5647             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5648      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5649           enddo
5650         enddo
5651         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5652         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5653  1215   continue
5654       enddo
5655       return
5656       end
5657 #endif
5658 c------------------------------------------------------------------------------
5659       subroutine eback_sc_corr(esccor)
5660 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5661 c        conformational states; temporarily implemented as differences
5662 c        between UNRES torsional potentials (dependent on three types of
5663 c        residues) and the torsional potentials dependent on all 20 types
5664 c        of residues computed from AM1 energy surfaces of terminally-blocked
5665 c        amino-acid residues.
5666       implicit real*8 (a-h,o-z)
5667       include 'DIMENSIONS'
5668       include 'DIMENSIONS.ZSCOPT'
5669       include 'COMMON.VAR'
5670       include 'COMMON.GEO'
5671       include 'COMMON.LOCAL'
5672       include 'COMMON.TORSION'
5673       include 'COMMON.SCCOR'
5674       include 'COMMON.INTERACT'
5675       include 'COMMON.DERIV'
5676       include 'COMMON.CHAIN'
5677       include 'COMMON.NAMES'
5678       include 'COMMON.IOUNITS'
5679       include 'COMMON.FFIELD'
5680       include 'COMMON.CONTROL'
5681       logical lprn
5682 C Set lprn=.true. for debugging
5683       lprn=.false.
5684 c      lprn=.true.
5685 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5686       esccor=0.0D0
5687       do i=itau_start,itau_end
5688         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5689         esccor_ii=0.0D0
5690         isccori=isccortyp(itype(i-2))
5691         isccori1=isccortyp(itype(i-1))
5692         phii=phi(i)
5693         do intertyp=1,3 !intertyp
5694 cc Added 09 May 2012 (Adasko)
5695 cc  Intertyp means interaction type of backbone mainchain correlation:
5696 c   1 = SC...Ca...Ca...Ca
5697 c   2 = Ca...Ca...Ca...SC
5698 c   3 = SC...Ca...Ca...SCi
5699         gloci=0.0D0
5700         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5701      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5702      &      (itype(i-1).eq.ntyp1)))
5703      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5704      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5705      &     .or.(itype(i).eq.ntyp1)))
5706      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5707      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5708      &      (itype(i-3).eq.ntyp1)))) cycle
5709         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5710         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5711      & cycle
5712        do j=1,nterm_sccor(isccori,isccori1)
5713           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5714           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5715           cosphi=dcos(j*tauangle(intertyp,i))
5716           sinphi=dsin(j*tauangle(intertyp,i))
5717            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5718            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5719          enddo
5720 C      write (iout,*)"EBACK_SC_COR",esccor,i
5721 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5722 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5723 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5724         if (lprn)
5725      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5726      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5727      &  (v1sccor(j,1,itori,itori1),j=1,6)
5728      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5729 c        gsccor_loc(i-3)=gloci
5730        enddo !intertyp
5731       enddo
5732       return
5733       end
5734 c------------------------------------------------------------------------------
5735       subroutine multibody(ecorr)
5736 C This subroutine calculates multi-body contributions to energy following
5737 C the idea of Skolnick et al. If side chains I and J make a contact and
5738 C at the same time side chains I+1 and J+1 make a contact, an extra
5739 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5740       implicit real*8 (a-h,o-z)
5741       include 'DIMENSIONS'
5742       include 'COMMON.IOUNITS'
5743       include 'COMMON.DERIV'
5744       include 'COMMON.INTERACT'
5745       include 'COMMON.CONTACTS'
5746       double precision gx(3),gx1(3)
5747       logical lprn
5748
5749 C Set lprn=.true. for debugging
5750       lprn=.false.
5751
5752       if (lprn) then
5753         write (iout,'(a)') 'Contact function values:'
5754         do i=nnt,nct-2
5755           write (iout,'(i2,20(1x,i2,f10.5))')
5756      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5757         enddo
5758       endif
5759       ecorr=0.0D0
5760       do i=nnt,nct
5761         do j=1,3
5762           gradcorr(j,i)=0.0D0
5763           gradxorr(j,i)=0.0D0
5764         enddo
5765       enddo
5766       do i=nnt,nct-2
5767
5768         DO ISHIFT = 3,4
5769
5770         i1=i+ishift
5771         num_conti=num_cont(i)
5772         num_conti1=num_cont(i1)
5773         do jj=1,num_conti
5774           j=jcont(jj,i)
5775           do kk=1,num_conti1
5776             j1=jcont(kk,i1)
5777             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5778 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5779 cd   &                   ' ishift=',ishift
5780 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5781 C The system gains extra energy.
5782               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5783             endif   ! j1==j+-ishift
5784           enddo     ! kk
5785         enddo       ! jj
5786
5787         ENDDO ! ISHIFT
5788
5789       enddo         ! i
5790       return
5791       end
5792 c------------------------------------------------------------------------------
5793       double precision function esccorr(i,j,k,l,jj,kk)
5794       implicit real*8 (a-h,o-z)
5795       include 'DIMENSIONS'
5796       include 'COMMON.IOUNITS'
5797       include 'COMMON.DERIV'
5798       include 'COMMON.INTERACT'
5799       include 'COMMON.CONTACTS'
5800       double precision gx(3),gx1(3)
5801       logical lprn
5802       lprn=.false.
5803       eij=facont(jj,i)
5804       ekl=facont(kk,k)
5805 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5806 C Calculate the multi-body contribution to energy.
5807 C Calculate multi-body contributions to the gradient.
5808 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5809 cd   & k,l,(gacont(m,kk,k),m=1,3)
5810       do m=1,3
5811         gx(m) =ekl*gacont(m,jj,i)
5812         gx1(m)=eij*gacont(m,kk,k)
5813         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5814         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5815         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5816         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5817       enddo
5818       do m=i,j-1
5819         do ll=1,3
5820           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5821         enddo
5822       enddo
5823       do m=k,l-1
5824         do ll=1,3
5825           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5826         enddo
5827       enddo
5828       esccorr=-eij*ekl
5829       return
5830       end
5831 c------------------------------------------------------------------------------
5832 #ifdef MPL
5833       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5834       implicit real*8 (a-h,o-z)
5835       include 'DIMENSIONS'
5836       integer dimen1,dimen2,atom,indx
5837       double precision buffer(dimen1,dimen2)
5838       double precision zapas
5839       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5840      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5841      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5842       num_kont=num_cont_hb(atom)
5843       do i=1,num_kont
5844         do k=1,7
5845           do j=1,3
5846             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5847           enddo ! j
5848         enddo ! k
5849         buffer(i,indx+22)=facont_hb(i,atom)
5850         buffer(i,indx+23)=ees0p(i,atom)
5851         buffer(i,indx+24)=ees0m(i,atom)
5852         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5853       enddo ! i
5854       buffer(1,indx+26)=dfloat(num_kont)
5855       return
5856       end
5857 c------------------------------------------------------------------------------
5858       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5859       implicit real*8 (a-h,o-z)
5860       include 'DIMENSIONS'
5861       integer dimen1,dimen2,atom,indx
5862       double precision buffer(dimen1,dimen2)
5863       double precision zapas
5864       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5865      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5866      &         ees0m(ntyp,maxres),
5867      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5868       num_kont=buffer(1,indx+26)
5869       num_kont_old=num_cont_hb(atom)
5870       num_cont_hb(atom)=num_kont+num_kont_old
5871       do i=1,num_kont
5872         ii=i+num_kont_old
5873         do k=1,7
5874           do j=1,3
5875             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5876           enddo ! j
5877         enddo ! k
5878         facont_hb(ii,atom)=buffer(i,indx+22)
5879         ees0p(ii,atom)=buffer(i,indx+23)
5880         ees0m(ii,atom)=buffer(i,indx+24)
5881         jcont_hb(ii,atom)=buffer(i,indx+25)
5882       enddo ! i
5883       return
5884       end
5885 c------------------------------------------------------------------------------
5886 #endif
5887       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5888 C This subroutine calculates multi-body contributions to hydrogen-bonding
5889       implicit real*8 (a-h,o-z)
5890       include 'DIMENSIONS'
5891       include 'DIMENSIONS.ZSCOPT'
5892       include 'COMMON.IOUNITS'
5893 #ifdef MPL
5894       include 'COMMON.INFO'
5895 #endif
5896       include 'COMMON.FFIELD'
5897       include 'COMMON.DERIV'
5898       include 'COMMON.INTERACT'
5899       include 'COMMON.CONTACTS'
5900 #ifdef MPL
5901       parameter (max_cont=maxconts)
5902       parameter (max_dim=2*(8*3+2))
5903       parameter (msglen1=max_cont*max_dim*4)
5904       parameter (msglen2=2*msglen1)
5905       integer source,CorrelType,CorrelID,Error
5906       double precision buffer(max_cont,max_dim)
5907 #endif
5908       double precision gx(3),gx1(3)
5909       logical lprn,ldone
5910
5911 C Set lprn=.true. for debugging
5912       lprn=.false.
5913 #ifdef MPL
5914       n_corr=0
5915       n_corr1=0
5916       if (fgProcs.le.1) goto 30
5917       if (lprn) then
5918         write (iout,'(a)') 'Contact function values:'
5919         do i=nnt,nct-2
5920           write (iout,'(2i3,50(1x,i2,f5.2))')
5921      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5922      &    j=1,num_cont_hb(i))
5923         enddo
5924       endif
5925 C Caution! Following code assumes that electrostatic interactions concerning
5926 C a given atom are split among at most two processors!
5927       CorrelType=477
5928       CorrelID=MyID+1
5929       ldone=.false.
5930       do i=1,max_cont
5931         do j=1,max_dim
5932           buffer(i,j)=0.0D0
5933         enddo
5934       enddo
5935       mm=mod(MyRank,2)
5936 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5937       if (mm) 20,20,10
5938    10 continue
5939 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5940       if (MyRank.gt.0) then
5941 C Send correlation contributions to the preceding processor
5942         msglen=msglen1
5943         nn=num_cont_hb(iatel_s)
5944         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5945 cd      write (iout,*) 'The BUFFER array:'
5946 cd      do i=1,nn
5947 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5948 cd      enddo
5949         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5950           msglen=msglen2
5951             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5952 C Clear the contacts of the atom passed to the neighboring processor
5953         nn=num_cont_hb(iatel_s+1)
5954 cd      do i=1,nn
5955 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5956 cd      enddo
5957             num_cont_hb(iatel_s)=0
5958         endif
5959 cd      write (iout,*) 'Processor ',MyID,MyRank,
5960 cd   & ' is sending correlation contribution to processor',MyID-1,
5961 cd   & ' msglen=',msglen
5962 cd      write (*,*) 'Processor ',MyID,MyRank,
5963 cd   & ' is sending correlation contribution to processor',MyID-1,
5964 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5965         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5966 cd      write (iout,*) 'Processor ',MyID,
5967 cd   & ' has sent correlation contribution to processor',MyID-1,
5968 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5969 cd      write (*,*) 'Processor ',MyID,
5970 cd   & ' has sent correlation contribution to processor',MyID-1,
5971 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5972         msglen=msglen1
5973       endif ! (MyRank.gt.0)
5974       if (ldone) goto 30
5975       ldone=.true.
5976    20 continue
5977 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5978       if (MyRank.lt.fgProcs-1) then
5979 C Receive correlation contributions from the next processor
5980         msglen=msglen1
5981         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5982 cd      write (iout,*) 'Processor',MyID,
5983 cd   & ' is receiving correlation contribution from processor',MyID+1,
5984 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5985 cd      write (*,*) 'Processor',MyID,
5986 cd   & ' is receiving correlation contribution from processor',MyID+1,
5987 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5988         nbytes=-1
5989         do while (nbytes.le.0)
5990           call mp_probe(MyID+1,CorrelType,nbytes)
5991         enddo
5992 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5993         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5994 cd      write (iout,*) 'Processor',MyID,
5995 cd   & ' has received correlation contribution from processor',MyID+1,
5996 cd   & ' msglen=',msglen,' nbytes=',nbytes
5997 cd      write (iout,*) 'The received BUFFER array:'
5998 cd      do i=1,max_cont
5999 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6000 cd      enddo
6001         if (msglen.eq.msglen1) then
6002           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6003         else if (msglen.eq.msglen2)  then
6004           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6005           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6006         else
6007           write (iout,*)
6008      & 'ERROR!!!! message length changed while processing correlations.'
6009           write (*,*)
6010      & 'ERROR!!!! message length changed while processing correlations.'
6011           call mp_stopall(Error)
6012         endif ! msglen.eq.msglen1
6013       endif ! MyRank.lt.fgProcs-1
6014       if (ldone) goto 30
6015       ldone=.true.
6016       goto 10
6017    30 continue
6018 #endif
6019       if (lprn) then
6020         write (iout,'(a)') 'Contact function values:'
6021         do i=nnt,nct-2
6022           write (iout,'(2i3,50(1x,i2,f5.2))')
6023      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6024      &    j=1,num_cont_hb(i))
6025         enddo
6026       endif
6027       ecorr=0.0D0
6028 C Remove the loop below after debugging !!!
6029       do i=nnt,nct
6030         do j=1,3
6031           gradcorr(j,i)=0.0D0
6032           gradxorr(j,i)=0.0D0
6033         enddo
6034       enddo
6035 C Calculate the local-electrostatic correlation terms
6036       do i=iatel_s,iatel_e+1
6037         i1=i+1
6038         num_conti=num_cont_hb(i)
6039         num_conti1=num_cont_hb(i+1)
6040         do jj=1,num_conti
6041           j=jcont_hb(jj,i)
6042           do kk=1,num_conti1
6043             j1=jcont_hb(kk,i1)
6044 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6045 c     &         ' jj=',jj,' kk=',kk
6046             if (j1.eq.j+1 .or. j1.eq.j-1) then
6047 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6048 C The system gains extra energy.
6049               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6050               n_corr=n_corr+1
6051             else if (j1.eq.j) then
6052 C Contacts I-J and I-(J+1) occur simultaneously.
6053 C The system loses extra energy.
6054 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6055             endif
6056           enddo ! kk
6057           do kk=1,num_conti
6058             j1=jcont_hb(kk,i)
6059 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6060 c    &         ' jj=',jj,' kk=',kk
6061             if (j1.eq.j+1) then
6062 C Contacts I-J and (I+1)-J occur simultaneously.
6063 C The system loses extra energy.
6064 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6065             endif ! j1==j+1
6066           enddo ! kk
6067         enddo ! jj
6068       enddo ! i
6069       return
6070       end
6071 c------------------------------------------------------------------------------
6072       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6073      &  n_corr1)
6074 C This subroutine calculates multi-body contributions to hydrogen-bonding
6075       implicit real*8 (a-h,o-z)
6076       include 'DIMENSIONS'
6077       include 'DIMENSIONS.ZSCOPT'
6078       include 'COMMON.IOUNITS'
6079 #ifdef MPL
6080       include 'COMMON.INFO'
6081 #endif
6082       include 'COMMON.FFIELD'
6083       include 'COMMON.DERIV'
6084       include 'COMMON.INTERACT'
6085       include 'COMMON.CONTACTS'
6086 #ifdef MPL
6087       parameter (max_cont=maxconts)
6088       parameter (max_dim=2*(8*3+2))
6089       parameter (msglen1=max_cont*max_dim*4)
6090       parameter (msglen2=2*msglen1)
6091       integer source,CorrelType,CorrelID,Error
6092       double precision buffer(max_cont,max_dim)
6093 #endif
6094       double precision gx(3),gx1(3)
6095       logical lprn,ldone
6096
6097 C Set lprn=.true. for debugging
6098       lprn=.false.
6099       eturn6=0.0d0
6100       ecorr6=0.0d0
6101 #ifdef MPL
6102       n_corr=0
6103       n_corr1=0
6104       if (fgProcs.le.1) goto 30
6105       if (lprn) then
6106         write (iout,'(a)') 'Contact function values:'
6107         do i=nnt,nct-2
6108           write (iout,'(2i3,50(1x,i2,f5.2))')
6109      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6110      &    j=1,num_cont_hb(i))
6111         enddo
6112       endif
6113 C Caution! Following code assumes that electrostatic interactions concerning
6114 C a given atom are split among at most two processors!
6115       CorrelType=477
6116       CorrelID=MyID+1
6117       ldone=.false.
6118       do i=1,max_cont
6119         do j=1,max_dim
6120           buffer(i,j)=0.0D0
6121         enddo
6122       enddo
6123       mm=mod(MyRank,2)
6124 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6125       if (mm) 20,20,10
6126    10 continue
6127 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6128       if (MyRank.gt.0) then
6129 C Send correlation contributions to the preceding processor
6130         msglen=msglen1
6131         nn=num_cont_hb(iatel_s)
6132         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6133 cd      write (iout,*) 'The BUFFER array:'
6134 cd      do i=1,nn
6135 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6136 cd      enddo
6137         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6138           msglen=msglen2
6139             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6140 C Clear the contacts of the atom passed to the neighboring processor
6141         nn=num_cont_hb(iatel_s+1)
6142 cd      do i=1,nn
6143 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6144 cd      enddo
6145             num_cont_hb(iatel_s)=0
6146         endif
6147 cd      write (iout,*) 'Processor ',MyID,MyRank,
6148 cd   & ' is sending correlation contribution to processor',MyID-1,
6149 cd   & ' msglen=',msglen
6150 cd      write (*,*) 'Processor ',MyID,MyRank,
6151 cd   & ' is sending correlation contribution to processor',MyID-1,
6152 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6153         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6154 cd      write (iout,*) 'Processor ',MyID,
6155 cd   & ' has sent correlation contribution to processor',MyID-1,
6156 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6157 cd      write (*,*) 'Processor ',MyID,
6158 cd   & ' has sent correlation contribution to processor',MyID-1,
6159 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6160         msglen=msglen1
6161       endif ! (MyRank.gt.0)
6162       if (ldone) goto 30
6163       ldone=.true.
6164    20 continue
6165 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6166       if (MyRank.lt.fgProcs-1) then
6167 C Receive correlation contributions from the next processor
6168         msglen=msglen1
6169         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6170 cd      write (iout,*) 'Processor',MyID,
6171 cd   & ' is receiving correlation contribution from processor',MyID+1,
6172 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6173 cd      write (*,*) 'Processor',MyID,
6174 cd   & ' is receiving correlation contribution from processor',MyID+1,
6175 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6176         nbytes=-1
6177         do while (nbytes.le.0)
6178           call mp_probe(MyID+1,CorrelType,nbytes)
6179         enddo
6180 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6181         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6182 cd      write (iout,*) 'Processor',MyID,
6183 cd   & ' has received correlation contribution from processor',MyID+1,
6184 cd   & ' msglen=',msglen,' nbytes=',nbytes
6185 cd      write (iout,*) 'The received BUFFER array:'
6186 cd      do i=1,max_cont
6187 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6188 cd      enddo
6189         if (msglen.eq.msglen1) then
6190           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6191         else if (msglen.eq.msglen2)  then
6192           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6193           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6194         else
6195           write (iout,*)
6196      & 'ERROR!!!! message length changed while processing correlations.'
6197           write (*,*)
6198      & 'ERROR!!!! message length changed while processing correlations.'
6199           call mp_stopall(Error)
6200         endif ! msglen.eq.msglen1
6201       endif ! MyRank.lt.fgProcs-1
6202       if (ldone) goto 30
6203       ldone=.true.
6204       goto 10
6205    30 continue
6206 #endif
6207       if (lprn) then
6208         write (iout,'(a)') 'Contact function values:'
6209         do i=nnt,nct-2
6210           write (iout,'(2i3,50(1x,i2,f5.2))')
6211      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6212      &    j=1,num_cont_hb(i))
6213         enddo
6214       endif
6215       ecorr=0.0D0
6216       ecorr5=0.0d0
6217       ecorr6=0.0d0
6218 C Remove the loop below after debugging !!!
6219       do i=nnt,nct
6220         do j=1,3
6221           gradcorr(j,i)=0.0D0
6222           gradxorr(j,i)=0.0D0
6223         enddo
6224       enddo
6225 C Calculate the dipole-dipole interaction energies
6226       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6227       do i=iatel_s,iatel_e+1
6228         num_conti=num_cont_hb(i)
6229         do jj=1,num_conti
6230           j=jcont_hb(jj,i)
6231           call dipole(i,j,jj)
6232         enddo
6233       enddo
6234       endif
6235 C Calculate the local-electrostatic correlation terms
6236       do i=iatel_s,iatel_e+1
6237         i1=i+1
6238         num_conti=num_cont_hb(i)
6239         num_conti1=num_cont_hb(i+1)
6240         do jj=1,num_conti
6241           j=jcont_hb(jj,i)
6242           do kk=1,num_conti1
6243             j1=jcont_hb(kk,i1)
6244 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6245 c     &         ' jj=',jj,' kk=',kk
6246             if (j1.eq.j+1 .or. j1.eq.j-1) then
6247 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6248 C The system gains extra energy.
6249               n_corr=n_corr+1
6250               sqd1=dsqrt(d_cont(jj,i))
6251               sqd2=dsqrt(d_cont(kk,i1))
6252               sred_geom = sqd1*sqd2
6253               IF (sred_geom.lt.cutoff_corr) THEN
6254                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6255      &            ekont,fprimcont)
6256 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6257 c     &         ' jj=',jj,' kk=',kk
6258                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6259                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6260                 do l=1,3
6261                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6262                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6263                 enddo
6264                 n_corr1=n_corr1+1
6265 cd               write (iout,*) 'sred_geom=',sred_geom,
6266 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6267                 call calc_eello(i,j,i+1,j1,jj,kk)
6268                 if (wcorr4.gt.0.0d0)
6269      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6270                 if (wcorr5.gt.0.0d0)
6271      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6272 c                print *,"wcorr5",ecorr5
6273 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6274 cd                write(2,*)'ijkl',i,j,i+1,j1
6275                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6276      &               .or. wturn6.eq.0.0d0))then
6277 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6278                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6279 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6280 cd     &            'ecorr6=',ecorr6
6281 cd                write (iout,'(4e15.5)') sred_geom,
6282 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6283 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6284 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6285                 else if (wturn6.gt.0.0d0
6286      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6287 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6288                   eturn6=eturn6+eello_turn6(i,jj,kk)
6289 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6290                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6291                    eturn6=0.0d0
6292                    ecorr6=0.0d0
6293                 endif
6294
6295               ENDIF
6296 1111          continue
6297             else if (j1.eq.j) then
6298 C Contacts I-J and I-(J+1) occur simultaneously.
6299 C The system loses extra energy.
6300 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6301             endif
6302           enddo ! kk
6303           do kk=1,num_conti
6304             j1=jcont_hb(kk,i)
6305 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6306 c    &         ' jj=',jj,' kk=',kk
6307             if (j1.eq.j+1) then
6308 C Contacts I-J and (I+1)-J occur simultaneously.
6309 C The system loses extra energy.
6310 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6311             endif ! j1==j+1
6312           enddo ! kk
6313         enddo ! jj
6314       enddo ! i
6315       write (iout,*) "eturn6",eturn6,ecorr6
6316       return
6317       end
6318 c------------------------------------------------------------------------------
6319       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6320       implicit real*8 (a-h,o-z)
6321       include 'DIMENSIONS'
6322       include 'COMMON.IOUNITS'
6323       include 'COMMON.DERIV'
6324       include 'COMMON.INTERACT'
6325       include 'COMMON.CONTACTS'
6326       include 'COMMON.CONTROL'
6327       include 'COMMON.SHIELD'
6328       double precision gx(3),gx1(3)
6329       logical lprn
6330       lprn=.false.
6331       eij=facont_hb(jj,i)
6332       ekl=facont_hb(kk,k)
6333       ees0pij=ees0p(jj,i)
6334       ees0pkl=ees0p(kk,k)
6335       ees0mij=ees0m(jj,i)
6336       ees0mkl=ees0m(kk,k)
6337       ekont=eij*ekl
6338       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6339 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6340 C Following 4 lines for diagnostics.
6341 cd    ees0pkl=0.0D0
6342 cd    ees0pij=1.0D0
6343 cd    ees0mkl=0.0D0
6344 cd    ees0mij=1.0D0
6345 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6346 c    &   ' and',k,l
6347 c     write (iout,*)'Contacts have occurred for peptide groups',
6348 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6349 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6350 C Calculate the multi-body contribution to energy.
6351 C      ecorr=ecorr+ekont*ees
6352       if (calc_grad) then
6353 C Calculate multi-body contributions to the gradient.
6354       do ll=1,3
6355         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6356         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6357      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6358      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6359         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6360      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6361      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6362         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6363         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6364      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6365      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6366         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6367      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6368      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6369       enddo
6370       do m=i+1,j-1
6371         do ll=1,3
6372           gradcorr(ll,m)=gradcorr(ll,m)+
6373      &     ees*ekl*gacont_hbr(ll,jj,i)-
6374      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6375      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6376         enddo
6377       enddo
6378       do m=k+1,l-1
6379         do ll=1,3
6380           gradcorr(ll,m)=gradcorr(ll,m)+
6381      &     ees*eij*gacont_hbr(ll,kk,k)-
6382      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6383      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6384         enddo
6385       enddo
6386       if (shield_mode.gt.0) then
6387        j=ees0plist(jj,i)
6388        l=ees0plist(kk,k)
6389 C        print *,i,j,fac_shield(i),fac_shield(j),
6390 C     &fac_shield(k),fac_shield(l)
6391         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6392      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6393           do ilist=1,ishield_list(i)
6394            iresshield=shield_list(ilist,i)
6395            do m=1,3
6396            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6397 C     &      *2.0
6398            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6399      &              rlocshield
6400      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6401             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6402      &+rlocshield
6403            enddo
6404           enddo
6405           do ilist=1,ishield_list(j)
6406            iresshield=shield_list(ilist,j)
6407            do m=1,3
6408            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6409 C     &     *2.0
6410            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6411      &              rlocshield
6412      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6413            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6414      &     +rlocshield
6415            enddo
6416           enddo
6417           do ilist=1,ishield_list(k)
6418            iresshield=shield_list(ilist,k)
6419            do m=1,3
6420            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6421 C     &     *2.0
6422            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6423      &              rlocshield
6424      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6425            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6426      &     +rlocshield
6427            enddo
6428           enddo
6429           do ilist=1,ishield_list(l)
6430            iresshield=shield_list(ilist,l)
6431            do m=1,3
6432            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6433 C     &     *2.0
6434            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6435      &              rlocshield
6436      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6437            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6438      &     +rlocshield
6439            enddo
6440           enddo
6441 C          print *,gshieldx(m,iresshield)
6442           do m=1,3
6443             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6444      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6445             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6446      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6447             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6448      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6449             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6450      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6451
6452             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6453      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6454             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6455      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6456             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6457      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6458             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6459      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6460
6461            enddo
6462       endif
6463       endif
6464       endif
6465       ehbcorr=ekont*ees
6466       return
6467       end
6468 C---------------------------------------------------------------------------
6469       subroutine dipole(i,j,jj)
6470       implicit real*8 (a-h,o-z)
6471       include 'DIMENSIONS'
6472       include 'DIMENSIONS.ZSCOPT'
6473       include 'COMMON.IOUNITS'
6474       include 'COMMON.CHAIN'
6475       include 'COMMON.FFIELD'
6476       include 'COMMON.DERIV'
6477       include 'COMMON.INTERACT'
6478       include 'COMMON.CONTACTS'
6479       include 'COMMON.TORSION'
6480       include 'COMMON.VAR'
6481       include 'COMMON.GEO'
6482       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6483      &  auxmat(2,2)
6484       iti1 = itortyp(itype(i+1))
6485       if (j.lt.nres-1) then
6486         if (itype(j).le.ntyp) then
6487           itj1 = itortyp(itype(j+1))
6488         else
6489           itj=ntortyp+1
6490         endif
6491       else
6492         itj1=ntortyp+1
6493       endif
6494       do iii=1,2
6495         dipi(iii,1)=Ub2(iii,i)
6496         dipderi(iii)=Ub2der(iii,i)
6497         dipi(iii,2)=b1(iii,iti1)
6498         dipj(iii,1)=Ub2(iii,j)
6499         dipderj(iii)=Ub2der(iii,j)
6500         dipj(iii,2)=b1(iii,itj1)
6501       enddo
6502       kkk=0
6503       do iii=1,2
6504         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6505         do jjj=1,2
6506           kkk=kkk+1
6507           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6508         enddo
6509       enddo
6510       if (.not.calc_grad) return
6511       do kkk=1,5
6512         do lll=1,3
6513           mmm=0
6514           do iii=1,2
6515             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6516      &        auxvec(1))
6517             do jjj=1,2
6518               mmm=mmm+1
6519               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6520             enddo
6521           enddo
6522         enddo
6523       enddo
6524       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6525       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6526       do iii=1,2
6527         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6528       enddo
6529       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6530       do iii=1,2
6531         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6532       enddo
6533       return
6534       end
6535 C---------------------------------------------------------------------------
6536       subroutine calc_eello(i,j,k,l,jj,kk)
6537 C
6538 C This subroutine computes matrices and vectors needed to calculate
6539 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6540 C
6541       implicit real*8 (a-h,o-z)
6542       include 'DIMENSIONS'
6543       include 'DIMENSIONS.ZSCOPT'
6544       include 'COMMON.IOUNITS'
6545       include 'COMMON.CHAIN'
6546       include 'COMMON.DERIV'
6547       include 'COMMON.INTERACT'
6548       include 'COMMON.CONTACTS'
6549       include 'COMMON.TORSION'
6550       include 'COMMON.VAR'
6551       include 'COMMON.GEO'
6552       include 'COMMON.FFIELD'
6553       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6554      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6555       logical lprn
6556       common /kutas/ lprn
6557 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6558 cd     & ' jj=',jj,' kk=',kk
6559 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6560       do iii=1,2
6561         do jjj=1,2
6562           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6563           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6564         enddo
6565       enddo
6566       call transpose2(aa1(1,1),aa1t(1,1))
6567       call transpose2(aa2(1,1),aa2t(1,1))
6568       do kkk=1,5
6569         do lll=1,3
6570           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6571      &      aa1tder(1,1,lll,kkk))
6572           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6573      &      aa2tder(1,1,lll,kkk))
6574         enddo
6575       enddo
6576       if (l.eq.j+1) then
6577 C parallel orientation of the two CA-CA-CA frames.
6578         if (i.gt.1 .and. itype(i).le.ntyp) then
6579           iti=itortyp(itype(i))
6580         else
6581           iti=ntortyp+1
6582         endif
6583         itk1=itortyp(itype(k+1))
6584         itj=itortyp(itype(j))
6585         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6586           itl1=itortyp(itype(l+1))
6587         else
6588           itl1=ntortyp+1
6589         endif
6590 C A1 kernel(j+1) A2T
6591 cd        do iii=1,2
6592 cd          write (iout,'(3f10.5,5x,3f10.5)')
6593 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6594 cd        enddo
6595         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6596      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6597      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6598 C Following matrices are needed only for 6-th order cumulants
6599         IF (wcorr6.gt.0.0d0) THEN
6600         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6601      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6602      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6603         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6604      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6605      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6606      &   ADtEAderx(1,1,1,1,1,1))
6607         lprn=.false.
6608         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6609      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6610      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6611      &   ADtEA1derx(1,1,1,1,1,1))
6612         ENDIF
6613 C End 6-th order cumulants
6614 cd        lprn=.false.
6615 cd        if (lprn) then
6616 cd        write (2,*) 'In calc_eello6'
6617 cd        do iii=1,2
6618 cd          write (2,*) 'iii=',iii
6619 cd          do kkk=1,5
6620 cd            write (2,*) 'kkk=',kkk
6621 cd            do jjj=1,2
6622 cd              write (2,'(3(2f10.5),5x)')
6623 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6624 cd            enddo
6625 cd          enddo
6626 cd        enddo
6627 cd        endif
6628         call transpose2(EUgder(1,1,k),auxmat(1,1))
6629         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6630         call transpose2(EUg(1,1,k),auxmat(1,1))
6631         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6632         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6633         do iii=1,2
6634           do kkk=1,5
6635             do lll=1,3
6636               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6637      &          EAEAderx(1,1,lll,kkk,iii,1))
6638             enddo
6639           enddo
6640         enddo
6641 C A1T kernel(i+1) A2
6642         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6643      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6644      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6645 C Following matrices are needed only for 6-th order cumulants
6646         IF (wcorr6.gt.0.0d0) THEN
6647         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6648      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6649      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(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.,Ug2DtEUg(1,1,k),
6652      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6653      &   ADtEAderx(1,1,1,1,1,2))
6654         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6655      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6656      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6657      &   ADtEA1derx(1,1,1,1,1,2))
6658         ENDIF
6659 C End 6-th order cumulants
6660         call transpose2(EUgder(1,1,l),auxmat(1,1))
6661         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6662         call transpose2(EUg(1,1,l),auxmat(1,1))
6663         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6664         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6665         do iii=1,2
6666           do kkk=1,5
6667             do lll=1,3
6668               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6669      &          EAEAderx(1,1,lll,kkk,iii,2))
6670             enddo
6671           enddo
6672         enddo
6673 C AEAb1 and AEAb2
6674 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6675 C They are needed only when the fifth- or the sixth-order cumulants are
6676 C indluded.
6677         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6678         call transpose2(AEA(1,1,1),auxmat(1,1))
6679         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6680         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6681         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6682         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6683         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6684         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6685         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6686         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6687         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6688         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6689         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6690         call transpose2(AEA(1,1,2),auxmat(1,1))
6691         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6692         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6693         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6694         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6695         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6696         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6697         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6698         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6699         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6700         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6701         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6702 C Calculate the Cartesian derivatives of the vectors.
6703         do iii=1,2
6704           do kkk=1,5
6705             do lll=1,3
6706               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6707               call matvec2(auxmat(1,1),b1(1,iti),
6708      &          AEAb1derx(1,lll,kkk,iii,1,1))
6709               call matvec2(auxmat(1,1),Ub2(1,i),
6710      &          AEAb2derx(1,lll,kkk,iii,1,1))
6711               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6712      &          AEAb1derx(1,lll,kkk,iii,2,1))
6713               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6714      &          AEAb2derx(1,lll,kkk,iii,2,1))
6715               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6716               call matvec2(auxmat(1,1),b1(1,itj),
6717      &          AEAb1derx(1,lll,kkk,iii,1,2))
6718               call matvec2(auxmat(1,1),Ub2(1,j),
6719      &          AEAb2derx(1,lll,kkk,iii,1,2))
6720               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6721      &          AEAb1derx(1,lll,kkk,iii,2,2))
6722               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6723      &          AEAb2derx(1,lll,kkk,iii,2,2))
6724             enddo
6725           enddo
6726         enddo
6727         ENDIF
6728 C End vectors
6729       else
6730 C Antiparallel orientation of the two CA-CA-CA frames.
6731         if (i.gt.1 .and. itype(i).le.ntyp) then
6732           iti=itortyp(itype(i))
6733         else
6734           iti=ntortyp+1
6735         endif
6736         itk1=itortyp(itype(k+1))
6737         itl=itortyp(itype(l))
6738         itj=itortyp(itype(j))
6739         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6740           itj1=itortyp(itype(j+1))
6741         else
6742           itj1=ntortyp+1
6743         endif
6744 C A2 kernel(j-1)T A1T
6745         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6746      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6747      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6748 C Following matrices are needed only for 6-th order cumulants
6749         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6750      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6751         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6752      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6753      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6754         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6755      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6756      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6757      &   ADtEAderx(1,1,1,1,1,1))
6758         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6759      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6760      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6761      &   ADtEA1derx(1,1,1,1,1,1))
6762         ENDIF
6763 C End 6-th order cumulants
6764         call transpose2(EUgder(1,1,k),auxmat(1,1))
6765         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6766         call transpose2(EUg(1,1,k),auxmat(1,1))
6767         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6768         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6769         do iii=1,2
6770           do kkk=1,5
6771             do lll=1,3
6772               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6773      &          EAEAderx(1,1,lll,kkk,iii,1))
6774             enddo
6775           enddo
6776         enddo
6777 C A2T kernel(i+1)T A1
6778         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6779      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6780      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6781 C Following matrices are needed only for 6-th order cumulants
6782         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6783      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6784         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6785      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6786      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(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.,Ug2DtEUg(1,1,k),
6789      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6790      &   ADtEAderx(1,1,1,1,1,2))
6791         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6792      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6793      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6794      &   ADtEA1derx(1,1,1,1,1,2))
6795         ENDIF
6796 C End 6-th order cumulants
6797         call transpose2(EUgder(1,1,j),auxmat(1,1))
6798         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6799         call transpose2(EUg(1,1,j),auxmat(1,1))
6800         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6801         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6802         do iii=1,2
6803           do kkk=1,5
6804             do lll=1,3
6805               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6806      &          EAEAderx(1,1,lll,kkk,iii,2))
6807             enddo
6808           enddo
6809         enddo
6810 C AEAb1 and AEAb2
6811 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6812 C They are needed only when the fifth- or the sixth-order cumulants are
6813 C indluded.
6814         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6815      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6816         call transpose2(AEA(1,1,1),auxmat(1,1))
6817         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6818         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6819         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6820         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6821         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6822         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6823         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6824         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6825         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6826         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6827         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6828         call transpose2(AEA(1,1,2),auxmat(1,1))
6829         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6830         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6831         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6832         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6833         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6834         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6835         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6836         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6837         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6838         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6839         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6840 C Calculate the Cartesian derivatives of the vectors.
6841         do iii=1,2
6842           do kkk=1,5
6843             do lll=1,3
6844               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6845               call matvec2(auxmat(1,1),b1(1,iti),
6846      &          AEAb1derx(1,lll,kkk,iii,1,1))
6847               call matvec2(auxmat(1,1),Ub2(1,i),
6848      &          AEAb2derx(1,lll,kkk,iii,1,1))
6849               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6850      &          AEAb1derx(1,lll,kkk,iii,2,1))
6851               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6852      &          AEAb2derx(1,lll,kkk,iii,2,1))
6853               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6854               call matvec2(auxmat(1,1),b1(1,itl),
6855      &          AEAb1derx(1,lll,kkk,iii,1,2))
6856               call matvec2(auxmat(1,1),Ub2(1,l),
6857      &          AEAb2derx(1,lll,kkk,iii,1,2))
6858               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6859      &          AEAb1derx(1,lll,kkk,iii,2,2))
6860               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6861      &          AEAb2derx(1,lll,kkk,iii,2,2))
6862             enddo
6863           enddo
6864         enddo
6865         ENDIF
6866 C End vectors
6867       endif
6868       return
6869       end
6870 C---------------------------------------------------------------------------
6871       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6872      &  KK,KKderg,AKA,AKAderg,AKAderx)
6873       implicit none
6874       integer nderg
6875       logical transp
6876       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6877      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6878      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6879       integer iii,kkk,lll
6880       integer jjj,mmm
6881       logical lprn
6882       common /kutas/ lprn
6883       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6884       do iii=1,nderg
6885         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6886      &    AKAderg(1,1,iii))
6887       enddo
6888 cd      if (lprn) write (2,*) 'In kernel'
6889       do kkk=1,5
6890 cd        if (lprn) write (2,*) 'kkk=',kkk
6891         do lll=1,3
6892           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6893      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6894 cd          if (lprn) then
6895 cd            write (2,*) 'lll=',lll
6896 cd            write (2,*) 'iii=1'
6897 cd            do jjj=1,2
6898 cd              write (2,'(3(2f10.5),5x)')
6899 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6900 cd            enddo
6901 cd          endif
6902           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6903      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6904 cd          if (lprn) then
6905 cd            write (2,*) 'lll=',lll
6906 cd            write (2,*) 'iii=2'
6907 cd            do jjj=1,2
6908 cd              write (2,'(3(2f10.5),5x)')
6909 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6910 cd            enddo
6911 cd          endif
6912         enddo
6913       enddo
6914       return
6915       end
6916 C---------------------------------------------------------------------------
6917       double precision function eello4(i,j,k,l,jj,kk)
6918       implicit real*8 (a-h,o-z)
6919       include 'DIMENSIONS'
6920       include 'DIMENSIONS.ZSCOPT'
6921       include 'COMMON.IOUNITS'
6922       include 'COMMON.CHAIN'
6923       include 'COMMON.DERIV'
6924       include 'COMMON.INTERACT'
6925       include 'COMMON.CONTACTS'
6926       include 'COMMON.TORSION'
6927       include 'COMMON.VAR'
6928       include 'COMMON.GEO'
6929       double precision pizda(2,2),ggg1(3),ggg2(3)
6930 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6931 cd        eello4=0.0d0
6932 cd        return
6933 cd      endif
6934 cd      print *,'eello4:',i,j,k,l,jj,kk
6935 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6936 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6937 cold      eij=facont_hb(jj,i)
6938 cold      ekl=facont_hb(kk,k)
6939 cold      ekont=eij*ekl
6940       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6941       if (calc_grad) then
6942 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6943       gcorr_loc(k-1)=gcorr_loc(k-1)
6944      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6945       if (l.eq.j+1) then
6946         gcorr_loc(l-1)=gcorr_loc(l-1)
6947      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6948       else
6949         gcorr_loc(j-1)=gcorr_loc(j-1)
6950      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6951       endif
6952       do iii=1,2
6953         do kkk=1,5
6954           do lll=1,3
6955             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6956      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6957 cd            derx(lll,kkk,iii)=0.0d0
6958           enddo
6959         enddo
6960       enddo
6961 cd      gcorr_loc(l-1)=0.0d0
6962 cd      gcorr_loc(j-1)=0.0d0
6963 cd      gcorr_loc(k-1)=0.0d0
6964 cd      eel4=1.0d0
6965 cd      write (iout,*)'Contacts have occurred for peptide groups',
6966 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6967 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6968       if (j.lt.nres-1) then
6969         j1=j+1
6970         j2=j-1
6971       else
6972         j1=j-1
6973         j2=j-2
6974       endif
6975       if (l.lt.nres-1) then
6976         l1=l+1
6977         l2=l-1
6978       else
6979         l1=l-1
6980         l2=l-2
6981       endif
6982       do ll=1,3
6983 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6984         ggg1(ll)=eel4*g_contij(ll,1)
6985         ggg2(ll)=eel4*g_contij(ll,2)
6986         ghalf=0.5d0*ggg1(ll)
6987 cd        ghalf=0.0d0
6988         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6989         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6990         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6991         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6992 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6993         ghalf=0.5d0*ggg2(ll)
6994 cd        ghalf=0.0d0
6995         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6996         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6997         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6998         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6999       enddo
7000 cd      goto 1112
7001       do m=i+1,j-1
7002         do ll=1,3
7003 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7004           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7005         enddo
7006       enddo
7007       do m=k+1,l-1
7008         do ll=1,3
7009 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7010           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7011         enddo
7012       enddo
7013 1112  continue
7014       do m=i+2,j2
7015         do ll=1,3
7016           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7017         enddo
7018       enddo
7019       do m=k+2,l2
7020         do ll=1,3
7021           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7022         enddo
7023       enddo
7024 cd      do iii=1,nres-3
7025 cd        write (2,*) iii,gcorr_loc(iii)
7026 cd      enddo
7027       endif
7028       eello4=ekont*eel4
7029 cd      write (2,*) 'ekont',ekont
7030 cd      write (iout,*) 'eello4',ekont*eel4
7031       return
7032       end
7033 C---------------------------------------------------------------------------
7034       double precision function eello5(i,j,k,l,jj,kk)
7035       implicit real*8 (a-h,o-z)
7036       include 'DIMENSIONS'
7037       include 'DIMENSIONS.ZSCOPT'
7038       include 'COMMON.IOUNITS'
7039       include 'COMMON.CHAIN'
7040       include 'COMMON.DERIV'
7041       include 'COMMON.INTERACT'
7042       include 'COMMON.CONTACTS'
7043       include 'COMMON.TORSION'
7044       include 'COMMON.VAR'
7045       include 'COMMON.GEO'
7046       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7047       double precision ggg1(3),ggg2(3)
7048 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7049 C                                                                              C
7050 C                            Parallel chains                                   C
7051 C                                                                              C
7052 C          o             o                   o             o                   C
7053 C         /l\           / \             \   / \           / \   /              C
7054 C        /   \         /   \             \ /   \         /   \ /               C
7055 C       j| o |l1       | o |              o| o |         | o |o                C
7056 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7057 C      \i/   \         /   \ /             /   \         /   \                 C
7058 C       o    k1             o                                                  C
7059 C         (I)          (II)                (III)          (IV)                 C
7060 C                                                                              C
7061 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7062 C                                                                              C
7063 C                            Antiparallel chains                               C
7064 C                                                                              C
7065 C          o             o                   o             o                   C
7066 C         /j\           / \             \   / \           / \   /              C
7067 C        /   \         /   \             \ /   \         /   \ /               C
7068 C      j1| o |l        | o |              o| o |         | o |o                C
7069 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7070 C      \i/   \         /   \ /             /   \         /   \                 C
7071 C       o     k1            o                                                  C
7072 C         (I)          (II)                (III)          (IV)                 C
7073 C                                                                              C
7074 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7075 C                                                                              C
7076 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7077 C                                                                              C
7078 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7079 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7080 cd        eello5=0.0d0
7081 cd        return
7082 cd      endif
7083 cd      write (iout,*)
7084 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7085 cd     &   ' and',k,l
7086       itk=itortyp(itype(k))
7087       itl=itortyp(itype(l))
7088       itj=itortyp(itype(j))
7089       eello5_1=0.0d0
7090       eello5_2=0.0d0
7091       eello5_3=0.0d0
7092       eello5_4=0.0d0
7093 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7094 cd     &   eel5_3_num,eel5_4_num)
7095       do iii=1,2
7096         do kkk=1,5
7097           do lll=1,3
7098             derx(lll,kkk,iii)=0.0d0
7099           enddo
7100         enddo
7101       enddo
7102 cd      eij=facont_hb(jj,i)
7103 cd      ekl=facont_hb(kk,k)
7104 cd      ekont=eij*ekl
7105 cd      write (iout,*)'Contacts have occurred for peptide groups',
7106 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7107 cd      goto 1111
7108 C Contribution from the graph I.
7109 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7110 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7111       call transpose2(EUg(1,1,k),auxmat(1,1))
7112       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7113       vv(1)=pizda(1,1)-pizda(2,2)
7114       vv(2)=pizda(1,2)+pizda(2,1)
7115       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7116      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7117       if (calc_grad) then
7118 C Explicit gradient in virtual-dihedral angles.
7119       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7120      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7121      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7122       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7123       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7124       vv(1)=pizda(1,1)-pizda(2,2)
7125       vv(2)=pizda(1,2)+pizda(2,1)
7126       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7127      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7128      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7129       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7130       vv(1)=pizda(1,1)-pizda(2,2)
7131       vv(2)=pizda(1,2)+pizda(2,1)
7132       if (l.eq.j+1) then
7133         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7134      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7135      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7136       else
7137         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7138      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7139      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7140       endif
7141 C Cartesian gradient
7142       do iii=1,2
7143         do kkk=1,5
7144           do lll=1,3
7145             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7146      &        pizda(1,1))
7147             vv(1)=pizda(1,1)-pizda(2,2)
7148             vv(2)=pizda(1,2)+pizda(2,1)
7149             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7150      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7151      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7152           enddo
7153         enddo
7154       enddo
7155 c      goto 1112
7156       endif
7157 c1111  continue
7158 C Contribution from graph II
7159       call transpose2(EE(1,1,itk),auxmat(1,1))
7160       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7161       vv(1)=pizda(1,1)+pizda(2,2)
7162       vv(2)=pizda(2,1)-pizda(1,2)
7163       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7164      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7165       if (calc_grad) then
7166 C Explicit gradient in virtual-dihedral angles.
7167       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7168      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7169       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7170       vv(1)=pizda(1,1)+pizda(2,2)
7171       vv(2)=pizda(2,1)-pizda(1,2)
7172       if (l.eq.j+1) then
7173         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7174      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7175      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7176       else
7177         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7178      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7179      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7180       endif
7181 C Cartesian gradient
7182       do iii=1,2
7183         do kkk=1,5
7184           do lll=1,3
7185             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7186      &        pizda(1,1))
7187             vv(1)=pizda(1,1)+pizda(2,2)
7188             vv(2)=pizda(2,1)-pizda(1,2)
7189             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7190      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7191      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7192           enddo
7193         enddo
7194       enddo
7195 cd      goto 1112
7196       endif
7197 cd1111  continue
7198       if (l.eq.j+1) then
7199 cd        goto 1110
7200 C Parallel orientation
7201 C Contribution from graph III
7202         call transpose2(EUg(1,1,l),auxmat(1,1))
7203         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7204         vv(1)=pizda(1,1)-pizda(2,2)
7205         vv(2)=pizda(1,2)+pizda(2,1)
7206         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7207      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7208         if (calc_grad) then
7209 C Explicit gradient in virtual-dihedral angles.
7210         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7211      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7212      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7213         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7214         vv(1)=pizda(1,1)-pizda(2,2)
7215         vv(2)=pizda(1,2)+pizda(2,1)
7216         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7217      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7218      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7219         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7220         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7221         vv(1)=pizda(1,1)-pizda(2,2)
7222         vv(2)=pizda(1,2)+pizda(2,1)
7223         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7224      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7225      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7226 C Cartesian gradient
7227         do iii=1,2
7228           do kkk=1,5
7229             do lll=1,3
7230               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7231      &          pizda(1,1))
7232               vv(1)=pizda(1,1)-pizda(2,2)
7233               vv(2)=pizda(1,2)+pizda(2,1)
7234               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7235      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7236      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7237             enddo
7238           enddo
7239         enddo
7240 cd        goto 1112
7241         endif
7242 C Contribution from graph IV
7243 cd1110    continue
7244         call transpose2(EE(1,1,itl),auxmat(1,1))
7245         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7246         vv(1)=pizda(1,1)+pizda(2,2)
7247         vv(2)=pizda(2,1)-pizda(1,2)
7248         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7249      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7250         if (calc_grad) then
7251 C Explicit gradient in virtual-dihedral angles.
7252         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7253      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7254         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7255         vv(1)=pizda(1,1)+pizda(2,2)
7256         vv(2)=pizda(2,1)-pizda(1,2)
7257         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7258      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7259      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7260 C Cartesian gradient
7261         do iii=1,2
7262           do kkk=1,5
7263             do lll=1,3
7264               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7265      &          pizda(1,1))
7266               vv(1)=pizda(1,1)+pizda(2,2)
7267               vv(2)=pizda(2,1)-pizda(1,2)
7268               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7269      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7270      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7271             enddo
7272           enddo
7273         enddo
7274         endif
7275       else
7276 C Antiparallel orientation
7277 C Contribution from graph III
7278 c        goto 1110
7279         call transpose2(EUg(1,1,j),auxmat(1,1))
7280         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7281         vv(1)=pizda(1,1)-pizda(2,2)
7282         vv(2)=pizda(1,2)+pizda(2,1)
7283         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7284      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7285         if (calc_grad) then
7286 C Explicit gradient in virtual-dihedral angles.
7287         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7288      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7289      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7290         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7291         vv(1)=pizda(1,1)-pizda(2,2)
7292         vv(2)=pizda(1,2)+pizda(2,1)
7293         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7294      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7295      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7296         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7297         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7298         vv(1)=pizda(1,1)-pizda(2,2)
7299         vv(2)=pizda(1,2)+pizda(2,1)
7300         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7301      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7302      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7303 C Cartesian gradient
7304         do iii=1,2
7305           do kkk=1,5
7306             do lll=1,3
7307               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7308      &          pizda(1,1))
7309               vv(1)=pizda(1,1)-pizda(2,2)
7310               vv(2)=pizda(1,2)+pizda(2,1)
7311               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7312      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7313      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7314             enddo
7315           enddo
7316         enddo
7317 cd        goto 1112
7318         endif
7319 C Contribution from graph IV
7320 1110    continue
7321         call transpose2(EE(1,1,itj),auxmat(1,1))
7322         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7323         vv(1)=pizda(1,1)+pizda(2,2)
7324         vv(2)=pizda(2,1)-pizda(1,2)
7325         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7326      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7327         if (calc_grad) then
7328 C Explicit gradient in virtual-dihedral angles.
7329         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7330      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7331         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7332         vv(1)=pizda(1,1)+pizda(2,2)
7333         vv(2)=pizda(2,1)-pizda(1,2)
7334         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7335      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7336      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7337 C Cartesian gradient
7338         do iii=1,2
7339           do kkk=1,5
7340             do lll=1,3
7341               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7342      &          pizda(1,1))
7343               vv(1)=pizda(1,1)+pizda(2,2)
7344               vv(2)=pizda(2,1)-pizda(1,2)
7345               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7346      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7347      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7348             enddo
7349           enddo
7350         enddo
7351       endif
7352       endif
7353 1112  continue
7354       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7355 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7356 cd        write (2,*) 'ijkl',i,j,k,l
7357 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7358 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7359 cd      endif
7360 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7361 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7362 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7363 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7364       if (calc_grad) then
7365       if (j.lt.nres-1) then
7366         j1=j+1
7367         j2=j-1
7368       else
7369         j1=j-1
7370         j2=j-2
7371       endif
7372       if (l.lt.nres-1) then
7373         l1=l+1
7374         l2=l-1
7375       else
7376         l1=l-1
7377         l2=l-2
7378       endif
7379 cd      eij=1.0d0
7380 cd      ekl=1.0d0
7381 cd      ekont=1.0d0
7382 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7383       do ll=1,3
7384         ggg1(ll)=eel5*g_contij(ll,1)
7385         ggg2(ll)=eel5*g_contij(ll,2)
7386 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7387         ghalf=0.5d0*ggg1(ll)
7388 cd        ghalf=0.0d0
7389         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7390         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7391         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7392         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7393 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7394         ghalf=0.5d0*ggg2(ll)
7395 cd        ghalf=0.0d0
7396         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7397         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7398         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7399         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7400       enddo
7401 cd      goto 1112
7402       do m=i+1,j-1
7403         do ll=1,3
7404 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7405           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7406         enddo
7407       enddo
7408       do m=k+1,l-1
7409         do ll=1,3
7410 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7411           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7412         enddo
7413       enddo
7414 c1112  continue
7415       do m=i+2,j2
7416         do ll=1,3
7417           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7418         enddo
7419       enddo
7420       do m=k+2,l2
7421         do ll=1,3
7422           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7423         enddo
7424       enddo
7425 cd      do iii=1,nres-3
7426 cd        write (2,*) iii,g_corr5_loc(iii)
7427 cd      enddo
7428       endif
7429       eello5=ekont*eel5
7430 cd      write (2,*) 'ekont',ekont
7431 cd      write (iout,*) 'eello5',ekont*eel5
7432       return
7433       end
7434 c--------------------------------------------------------------------------
7435       double precision function eello6(i,j,k,l,jj,kk)
7436       implicit real*8 (a-h,o-z)
7437       include 'DIMENSIONS'
7438       include 'DIMENSIONS.ZSCOPT'
7439       include 'COMMON.IOUNITS'
7440       include 'COMMON.CHAIN'
7441       include 'COMMON.DERIV'
7442       include 'COMMON.INTERACT'
7443       include 'COMMON.CONTACTS'
7444       include 'COMMON.TORSION'
7445       include 'COMMON.VAR'
7446       include 'COMMON.GEO'
7447       include 'COMMON.FFIELD'
7448       double precision ggg1(3),ggg2(3)
7449 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7450 cd        eello6=0.0d0
7451 cd        return
7452 cd      endif
7453 cd      write (iout,*)
7454 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7455 cd     &   ' and',k,l
7456       eello6_1=0.0d0
7457       eello6_2=0.0d0
7458       eello6_3=0.0d0
7459       eello6_4=0.0d0
7460       eello6_5=0.0d0
7461       eello6_6=0.0d0
7462 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7463 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7464       do iii=1,2
7465         do kkk=1,5
7466           do lll=1,3
7467             derx(lll,kkk,iii)=0.0d0
7468           enddo
7469         enddo
7470       enddo
7471 cd      eij=facont_hb(jj,i)
7472 cd      ekl=facont_hb(kk,k)
7473 cd      ekont=eij*ekl
7474 cd      eij=1.0d0
7475 cd      ekl=1.0d0
7476 cd      ekont=1.0d0
7477       if (l.eq.j+1) then
7478         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7479         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7480         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7481         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7482         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7483         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7484       else
7485         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7486         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7487         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7488         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7489         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7490           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7491         else
7492           eello6_5=0.0d0
7493         endif
7494         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7495       endif
7496 C If turn contributions are considered, they will be handled separately.
7497       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7498 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7499 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7500 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7501 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7502 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7503 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7504 cd      goto 1112
7505       if (calc_grad) then
7506       if (j.lt.nres-1) then
7507         j1=j+1
7508         j2=j-1
7509       else
7510         j1=j-1
7511         j2=j-2
7512       endif
7513       if (l.lt.nres-1) then
7514         l1=l+1
7515         l2=l-1
7516       else
7517         l1=l-1
7518         l2=l-2
7519       endif
7520       do ll=1,3
7521         ggg1(ll)=eel6*g_contij(ll,1)
7522         ggg2(ll)=eel6*g_contij(ll,2)
7523 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7524         ghalf=0.5d0*ggg1(ll)
7525 cd        ghalf=0.0d0
7526         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7527         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7528         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7529         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7530         ghalf=0.5d0*ggg2(ll)
7531 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7532 cd        ghalf=0.0d0
7533         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7534         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7535         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7536         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7537       enddo
7538 cd      goto 1112
7539       do m=i+1,j-1
7540         do ll=1,3
7541 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7542           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7543         enddo
7544       enddo
7545       do m=k+1,l-1
7546         do ll=1,3
7547 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7548           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7549         enddo
7550       enddo
7551 1112  continue
7552       do m=i+2,j2
7553         do ll=1,3
7554           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7555         enddo
7556       enddo
7557       do m=k+2,l2
7558         do ll=1,3
7559           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7560         enddo
7561       enddo
7562 cd      do iii=1,nres-3
7563 cd        write (2,*) iii,g_corr6_loc(iii)
7564 cd      enddo
7565       endif
7566       eello6=ekont*eel6
7567 cd      write (2,*) 'ekont',ekont
7568 cd      write (iout,*) 'eello6',ekont*eel6
7569       return
7570       end
7571 c--------------------------------------------------------------------------
7572       double precision function eello6_graph1(i,j,k,l,imat,swap)
7573       implicit real*8 (a-h,o-z)
7574       include 'DIMENSIONS'
7575       include 'DIMENSIONS.ZSCOPT'
7576       include 'COMMON.IOUNITS'
7577       include 'COMMON.CHAIN'
7578       include 'COMMON.DERIV'
7579       include 'COMMON.INTERACT'
7580       include 'COMMON.CONTACTS'
7581       include 'COMMON.TORSION'
7582       include 'COMMON.VAR'
7583       include 'COMMON.GEO'
7584       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7585       logical swap
7586       logical lprn
7587       common /kutas/ lprn
7588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7589 C                                                                              C
7590 C      Parallel       Antiparallel                                             C
7591 C                                                                              C
7592 C          o             o                                                     C
7593 C         /l\           /j\                                                    C
7594 C        /   \         /   \                                                   C
7595 C       /| o |         | o |\                                                  C
7596 C     \ j|/k\|  /   \  |/k\|l /                                                C
7597 C      \ /   \ /     \ /   \ /                                                 C
7598 C       o     o       o     o                                                  C
7599 C       i             i                                                        C
7600 C                                                                              C
7601 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7602       itk=itortyp(itype(k))
7603       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7604       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7605       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7606       call transpose2(EUgC(1,1,k),auxmat(1,1))
7607       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7608       vv1(1)=pizda1(1,1)-pizda1(2,2)
7609       vv1(2)=pizda1(1,2)+pizda1(2,1)
7610       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7611       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7612       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7613       s5=scalar2(vv(1),Dtobr2(1,i))
7614 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7615       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7616       if (.not. calc_grad) return
7617       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7618      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7619      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7620      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7621      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7622      & +scalar2(vv(1),Dtobr2der(1,i)))
7623       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7624       vv1(1)=pizda1(1,1)-pizda1(2,2)
7625       vv1(2)=pizda1(1,2)+pizda1(2,1)
7626       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7627       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7628       if (l.eq.j+1) then
7629         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7630      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7631      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7632      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7633      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7634       else
7635         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7636      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7637      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7638      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7639      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7640       endif
7641       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7642       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7643       vv1(1)=pizda1(1,1)-pizda1(2,2)
7644       vv1(2)=pizda1(1,2)+pizda1(2,1)
7645       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7646      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7647      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7648      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7649       do iii=1,2
7650         if (swap) then
7651           ind=3-iii
7652         else
7653           ind=iii
7654         endif
7655         do kkk=1,5
7656           do lll=1,3
7657             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7658             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7659             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7660             call transpose2(EUgC(1,1,k),auxmat(1,1))
7661             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7662      &        pizda1(1,1))
7663             vv1(1)=pizda1(1,1)-pizda1(2,2)
7664             vv1(2)=pizda1(1,2)+pizda1(2,1)
7665             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7666             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7667      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7668             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7669      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7670             s5=scalar2(vv(1),Dtobr2(1,i))
7671             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7672           enddo
7673         enddo
7674       enddo
7675       return
7676       end
7677 c----------------------------------------------------------------------------
7678       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7679       implicit real*8 (a-h,o-z)
7680       include 'DIMENSIONS'
7681       include 'DIMENSIONS.ZSCOPT'
7682       include 'COMMON.IOUNITS'
7683       include 'COMMON.CHAIN'
7684       include 'COMMON.DERIV'
7685       include 'COMMON.INTERACT'
7686       include 'COMMON.CONTACTS'
7687       include 'COMMON.TORSION'
7688       include 'COMMON.VAR'
7689       include 'COMMON.GEO'
7690       logical swap
7691       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7692      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7693       logical lprn
7694       common /kutas/ lprn
7695 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7696 C                                                                              C
7697 C      Parallel       Antiparallel                                             C
7698 C                                                                              C
7699 C          o             o                                                     C
7700 C     \   /l\           /j\   /                                                C
7701 C      \ /   \         /   \ /                                                 C
7702 C       o| o |         | o |o                                                  C
7703 C     \ j|/k\|      \  |/k\|l                                                  C
7704 C      \ /   \       \ /   \                                                   C
7705 C       o             o                                                        C
7706 C       i             i                                                        C
7707 C                                                                              C
7708 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7709 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7710 C AL 7/4/01 s1 would occur in the sixth-order moment,
7711 C           but not in a cluster cumulant
7712 #ifdef MOMENT
7713       s1=dip(1,jj,i)*dip(1,kk,k)
7714 #endif
7715       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7716       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7717       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7718       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7719       call transpose2(EUg(1,1,k),auxmat(1,1))
7720       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7721       vv(1)=pizda(1,1)-pizda(2,2)
7722       vv(2)=pizda(1,2)+pizda(2,1)
7723       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7724 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7725 #ifdef MOMENT
7726       eello6_graph2=-(s1+s2+s3+s4)
7727 #else
7728       eello6_graph2=-(s2+s3+s4)
7729 #endif
7730 c      eello6_graph2=-s3
7731       if (.not. calc_grad) return
7732 C Derivatives in gamma(i-1)
7733       if (i.gt.1) then
7734 #ifdef MOMENT
7735         s1=dipderg(1,jj,i)*dip(1,kk,k)
7736 #endif
7737         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7738         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7739         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7740         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7741 #ifdef MOMENT
7742         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7743 #else
7744         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7745 #endif
7746 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7747       endif
7748 C Derivatives in gamma(k-1)
7749 #ifdef MOMENT
7750       s1=dip(1,jj,i)*dipderg(1,kk,k)
7751 #endif
7752       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7753       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7754       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7755       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7756       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7757       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7758       vv(1)=pizda(1,1)-pizda(2,2)
7759       vv(2)=pizda(1,2)+pizda(2,1)
7760       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7761 #ifdef MOMENT
7762       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7763 #else
7764       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7765 #endif
7766 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7767 C Derivatives in gamma(j-1) or gamma(l-1)
7768       if (j.gt.1) then
7769 #ifdef MOMENT
7770         s1=dipderg(3,jj,i)*dip(1,kk,k)
7771 #endif
7772         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7773         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7774         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7775         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7776         vv(1)=pizda(1,1)-pizda(2,2)
7777         vv(2)=pizda(1,2)+pizda(2,1)
7778         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7779 #ifdef MOMENT
7780         if (swap) then
7781           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7782         else
7783           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7784         endif
7785 #endif
7786         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7787 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7788       endif
7789 C Derivatives in gamma(l-1) or gamma(j-1)
7790       if (l.gt.1) then
7791 #ifdef MOMENT
7792         s1=dip(1,jj,i)*dipderg(3,kk,k)
7793 #endif
7794         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7795         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7796         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7797         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7798         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7799         vv(1)=pizda(1,1)-pizda(2,2)
7800         vv(2)=pizda(1,2)+pizda(2,1)
7801         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7802 #ifdef MOMENT
7803         if (swap) then
7804           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7805         else
7806           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7807         endif
7808 #endif
7809         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7810 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7811       endif
7812 C Cartesian derivatives.
7813       if (lprn) then
7814         write (2,*) 'In eello6_graph2'
7815         do iii=1,2
7816           write (2,*) 'iii=',iii
7817           do kkk=1,5
7818             write (2,*) 'kkk=',kkk
7819             do jjj=1,2
7820               write (2,'(3(2f10.5),5x)')
7821      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7822             enddo
7823           enddo
7824         enddo
7825       endif
7826       do iii=1,2
7827         do kkk=1,5
7828           do lll=1,3
7829 #ifdef MOMENT
7830             if (iii.eq.1) then
7831               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7832             else
7833               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7834             endif
7835 #endif
7836             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7837      &        auxvec(1))
7838             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7839             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7840      &        auxvec(1))
7841             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7842             call transpose2(EUg(1,1,k),auxmat(1,1))
7843             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7844      &        pizda(1,1))
7845             vv(1)=pizda(1,1)-pizda(2,2)
7846             vv(2)=pizda(1,2)+pizda(2,1)
7847             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7848 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7849 #ifdef MOMENT
7850             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7851 #else
7852             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7853 #endif
7854             if (swap) then
7855               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7856             else
7857               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7858             endif
7859           enddo
7860         enddo
7861       enddo
7862       return
7863       end
7864 c----------------------------------------------------------------------------
7865       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7866       implicit real*8 (a-h,o-z)
7867       include 'DIMENSIONS'
7868       include 'DIMENSIONS.ZSCOPT'
7869       include 'COMMON.IOUNITS'
7870       include 'COMMON.CHAIN'
7871       include 'COMMON.DERIV'
7872       include 'COMMON.INTERACT'
7873       include 'COMMON.CONTACTS'
7874       include 'COMMON.TORSION'
7875       include 'COMMON.VAR'
7876       include 'COMMON.GEO'
7877       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7878       logical swap
7879 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7880 C                                                                              C
7881 C      Parallel       Antiparallel                                             C
7882 C                                                                              C
7883 C          o             o                                                     C
7884 C         /l\   /   \   /j\                                                    C
7885 C        /   \ /     \ /   \                                                   C
7886 C       /| o |o       o| o |\                                                  C
7887 C       j|/k\|  /      |/k\|l /                                                C
7888 C        /   \ /       /   \ /                                                 C
7889 C       /     o       /     o                                                  C
7890 C       i             i                                                        C
7891 C                                                                              C
7892 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7893 C
7894 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7895 C           energy moment and not to the cluster cumulant.
7896       iti=itortyp(itype(i))
7897       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7898         itj1=itortyp(itype(j+1))
7899       else
7900         itj1=ntortyp+1
7901       endif
7902       itk=itortyp(itype(k))
7903       itk1=itortyp(itype(k+1))
7904       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7905         itl1=itortyp(itype(l+1))
7906       else
7907         itl1=ntortyp+1
7908       endif
7909 #ifdef MOMENT
7910       s1=dip(4,jj,i)*dip(4,kk,k)
7911 #endif
7912       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7913       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7914       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7915       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7916       call transpose2(EE(1,1,itk),auxmat(1,1))
7917       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7918       vv(1)=pizda(1,1)+pizda(2,2)
7919       vv(2)=pizda(2,1)-pizda(1,2)
7920       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7921 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7922 #ifdef MOMENT
7923       eello6_graph3=-(s1+s2+s3+s4)
7924 #else
7925       eello6_graph3=-(s2+s3+s4)
7926 #endif
7927 c      eello6_graph3=-s4
7928       if (.not. calc_grad) return
7929 C Derivatives in gamma(k-1)
7930       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7931       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7932       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7933       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7934 C Derivatives in gamma(l-1)
7935       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7936       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7937       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7938       vv(1)=pizda(1,1)+pizda(2,2)
7939       vv(2)=pizda(2,1)-pizda(1,2)
7940       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7941       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7942 C Cartesian derivatives.
7943       do iii=1,2
7944         do kkk=1,5
7945           do lll=1,3
7946 #ifdef MOMENT
7947             if (iii.eq.1) then
7948               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7949             else
7950               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7951             endif
7952 #endif
7953             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7954      &        auxvec(1))
7955             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7956             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7957      &        auxvec(1))
7958             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7959             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7960      &        pizda(1,1))
7961             vv(1)=pizda(1,1)+pizda(2,2)
7962             vv(2)=pizda(2,1)-pizda(1,2)
7963             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7964 #ifdef MOMENT
7965             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7966 #else
7967             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7968 #endif
7969             if (swap) then
7970               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7971             else
7972               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7973             endif
7974 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7975           enddo
7976         enddo
7977       enddo
7978       return
7979       end
7980 c----------------------------------------------------------------------------
7981       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7982       implicit real*8 (a-h,o-z)
7983       include 'DIMENSIONS'
7984       include 'DIMENSIONS.ZSCOPT'
7985       include 'COMMON.IOUNITS'
7986       include 'COMMON.CHAIN'
7987       include 'COMMON.DERIV'
7988       include 'COMMON.INTERACT'
7989       include 'COMMON.CONTACTS'
7990       include 'COMMON.TORSION'
7991       include 'COMMON.VAR'
7992       include 'COMMON.GEO'
7993       include 'COMMON.FFIELD'
7994       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7995      & auxvec1(2),auxmat1(2,2)
7996       logical swap
7997 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7998 C                                                                              C
7999 C      Parallel       Antiparallel                                             C
8000 C                                                                              C
8001 C          o             o                                                     C
8002 C         /l\   /   \   /j\                                                    C
8003 C        /   \ /     \ /   \                                                   C
8004 C       /| o |o       o| o |\                                                  C
8005 C     \ j|/k\|      \  |/k\|l                                                  C
8006 C      \ /   \       \ /   \                                                   C
8007 C       o     \       o     \                                                  C
8008 C       i             i                                                        C
8009 C                                                                              C
8010 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8011 C
8012 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8013 C           energy moment and not to the cluster cumulant.
8014 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8015       iti=itortyp(itype(i))
8016       itj=itortyp(itype(j))
8017       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
8018         itj1=itortyp(itype(j+1))
8019       else
8020         itj1=ntortyp+1
8021       endif
8022       itk=itortyp(itype(k))
8023       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
8024         itk1=itortyp(itype(k+1))
8025       else
8026         itk1=ntortyp+1
8027       endif
8028       itl=itortyp(itype(l))
8029       if (l.lt.nres-1) then
8030         itl1=itortyp(itype(l+1))
8031       else
8032         itl1=ntortyp+1
8033       endif
8034 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8035 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8036 cd     & ' itl',itl,' itl1',itl1
8037 #ifdef MOMENT
8038       if (imat.eq.1) then
8039         s1=dip(3,jj,i)*dip(3,kk,k)
8040       else
8041         s1=dip(2,jj,j)*dip(2,kk,l)
8042       endif
8043 #endif
8044       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8045       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8046       if (j.eq.l+1) then
8047         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8048         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8049       else
8050         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8051         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8052       endif
8053       call transpose2(EUg(1,1,k),auxmat(1,1))
8054       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8055       vv(1)=pizda(1,1)-pizda(2,2)
8056       vv(2)=pizda(2,1)+pizda(1,2)
8057       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8058 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8059 #ifdef MOMENT
8060       eello6_graph4=-(s1+s2+s3+s4)
8061 #else
8062       eello6_graph4=-(s2+s3+s4)
8063 #endif
8064       if (.not. calc_grad) return
8065 C Derivatives in gamma(i-1)
8066       if (i.gt.1) then
8067 #ifdef MOMENT
8068         if (imat.eq.1) then
8069           s1=dipderg(2,jj,i)*dip(3,kk,k)
8070         else
8071           s1=dipderg(4,jj,j)*dip(2,kk,l)
8072         endif
8073 #endif
8074         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8075         if (j.eq.l+1) then
8076           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8077           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8078         else
8079           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8080           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8081         endif
8082         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8083         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8084 cd          write (2,*) 'turn6 derivatives'
8085 #ifdef MOMENT
8086           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8087 #else
8088           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8089 #endif
8090         else
8091 #ifdef MOMENT
8092           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8093 #else
8094           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8095 #endif
8096         endif
8097       endif
8098 C Derivatives in gamma(k-1)
8099 #ifdef MOMENT
8100       if (imat.eq.1) then
8101         s1=dip(3,jj,i)*dipderg(2,kk,k)
8102       else
8103         s1=dip(2,jj,j)*dipderg(4,kk,l)
8104       endif
8105 #endif
8106       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8107       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8108       if (j.eq.l+1) then
8109         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8110         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8111       else
8112         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8113         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8114       endif
8115       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8116       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8117       vv(1)=pizda(1,1)-pizda(2,2)
8118       vv(2)=pizda(2,1)+pizda(1,2)
8119       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8120       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8121 #ifdef MOMENT
8122         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8123 #else
8124         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8125 #endif
8126       else
8127 #ifdef MOMENT
8128         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8129 #else
8130         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8131 #endif
8132       endif
8133 C Derivatives in gamma(j-1) or gamma(l-1)
8134       if (l.eq.j+1 .and. l.gt.1) then
8135         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8136         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8137         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8138         vv(1)=pizda(1,1)-pizda(2,2)
8139         vv(2)=pizda(2,1)+pizda(1,2)
8140         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8141         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8142       else if (j.gt.1) then
8143         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8144         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8145         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8146         vv(1)=pizda(1,1)-pizda(2,2)
8147         vv(2)=pizda(2,1)+pizda(1,2)
8148         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8149         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8150           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8151         else
8152           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8153         endif
8154       endif
8155 C Cartesian derivatives.
8156       do iii=1,2
8157         do kkk=1,5
8158           do lll=1,3
8159 #ifdef MOMENT
8160             if (iii.eq.1) then
8161               if (imat.eq.1) then
8162                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8163               else
8164                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8165               endif
8166             else
8167               if (imat.eq.1) then
8168                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8169               else
8170                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8171               endif
8172             endif
8173 #endif
8174             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8175      &        auxvec(1))
8176             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8177             if (j.eq.l+1) then
8178               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8179      &          b1(1,itj1),auxvec(1))
8180               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8181             else
8182               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8183      &          b1(1,itl1),auxvec(1))
8184               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8185             endif
8186             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8187      &        pizda(1,1))
8188             vv(1)=pizda(1,1)-pizda(2,2)
8189             vv(2)=pizda(2,1)+pizda(1,2)
8190             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8191             if (swap) then
8192               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8193 #ifdef MOMENT
8194                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8195      &             -(s1+s2+s4)
8196 #else
8197                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8198      &             -(s2+s4)
8199 #endif
8200                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8201               else
8202 #ifdef MOMENT
8203                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8204 #else
8205                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8206 #endif
8207                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8208               endif
8209             else
8210 #ifdef MOMENT
8211               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8212 #else
8213               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8214 #endif
8215               if (l.eq.j+1) then
8216                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8217               else
8218                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8219               endif
8220             endif
8221           enddo
8222         enddo
8223       enddo
8224       return
8225       end
8226 c----------------------------------------------------------------------------
8227       double precision function eello_turn6(i,jj,kk)
8228       implicit real*8 (a-h,o-z)
8229       include 'DIMENSIONS'
8230       include 'DIMENSIONS.ZSCOPT'
8231       include 'COMMON.IOUNITS'
8232       include 'COMMON.CHAIN'
8233       include 'COMMON.DERIV'
8234       include 'COMMON.INTERACT'
8235       include 'COMMON.CONTACTS'
8236       include 'COMMON.TORSION'
8237       include 'COMMON.VAR'
8238       include 'COMMON.GEO'
8239       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8240      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8241      &  ggg1(3),ggg2(3)
8242       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8243      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8244 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8245 C           the respective energy moment and not to the cluster cumulant.
8246       eello_turn6=0.0d0
8247       j=i+4
8248       k=i+1
8249       l=i+3
8250       iti=itortyp(itype(i))
8251       itk=itortyp(itype(k))
8252       itk1=itortyp(itype(k+1))
8253       itl=itortyp(itype(l))
8254       itj=itortyp(itype(j))
8255 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8256 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8257 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8258 cd        eello6=0.0d0
8259 cd        return
8260 cd      endif
8261 cd      write (iout,*)
8262 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8263 cd     &   ' and',k,l
8264 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8265       do iii=1,2
8266         do kkk=1,5
8267           do lll=1,3
8268             derx_turn(lll,kkk,iii)=0.0d0
8269           enddo
8270         enddo
8271       enddo
8272 cd      eij=1.0d0
8273 cd      ekl=1.0d0
8274 cd      ekont=1.0d0
8275       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8276 cd      eello6_5=0.0d0
8277 cd      write (2,*) 'eello6_5',eello6_5
8278 #ifdef MOMENT
8279       call transpose2(AEA(1,1,1),auxmat(1,1))
8280       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8281       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8282       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8283 #else
8284       s1 = 0.0d0
8285 #endif
8286       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8287       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8288       s2 = scalar2(b1(1,itk),vtemp1(1))
8289 #ifdef MOMENT
8290       call transpose2(AEA(1,1,2),atemp(1,1))
8291       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8292       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8293       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8294 #else
8295       s8=0.0d0
8296 #endif
8297       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8298       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8299       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8300 #ifdef MOMENT
8301       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8302       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8303       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8304       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8305       ss13 = scalar2(b1(1,itk),vtemp4(1))
8306       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8307 #else
8308       s13=0.0d0
8309 #endif
8310 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8311 c      s1=0.0d0
8312 c      s2=0.0d0
8313 c      s8=0.0d0
8314 c      s12=0.0d0
8315 c      s13=0.0d0
8316       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8317       if (calc_grad) then
8318 C Derivatives in gamma(i+2)
8319 #ifdef MOMENT
8320       call transpose2(AEA(1,1,1),auxmatd(1,1))
8321       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8322       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8323       call transpose2(AEAderg(1,1,2),atempd(1,1))
8324       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8325       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8326 #else
8327       s8d=0.0d0
8328 #endif
8329       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8330       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8331       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8332 c      s1d=0.0d0
8333 c      s2d=0.0d0
8334 c      s8d=0.0d0
8335 c      s12d=0.0d0
8336 c      s13d=0.0d0
8337       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8338 C Derivatives in gamma(i+3)
8339 #ifdef MOMENT
8340       call transpose2(AEA(1,1,1),auxmatd(1,1))
8341       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8342       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8343       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8344 #else
8345       s1d=0.0d0
8346 #endif
8347       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8348       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8349       s2d = scalar2(b1(1,itk),vtemp1d(1))
8350 #ifdef MOMENT
8351       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8352       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8353 #endif
8354       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8355 #ifdef MOMENT
8356       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8357       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8358       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8359 #else
8360       s13d=0.0d0
8361 #endif
8362 c      s1d=0.0d0
8363 c      s2d=0.0d0
8364 c      s8d=0.0d0
8365 c      s12d=0.0d0
8366 c      s13d=0.0d0
8367 #ifdef MOMENT
8368       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8369      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8370 #else
8371       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8372      &               -0.5d0*ekont*(s2d+s12d)
8373 #endif
8374 C Derivatives in gamma(i+4)
8375       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8376       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8377       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8378 #ifdef MOMENT
8379       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8380       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8381       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8382 #else
8383       s13d = 0.0d0
8384 #endif
8385 c      s1d=0.0d0
8386 c      s2d=0.0d0
8387 c      s8d=0.0d0
8388 C      s12d=0.0d0
8389 c      s13d=0.0d0
8390 #ifdef MOMENT
8391       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8392 #else
8393       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8394 #endif
8395 C Derivatives in gamma(i+5)
8396 #ifdef MOMENT
8397       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8398       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8399       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8400 #else
8401       s1d = 0.0d0
8402 #endif
8403       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8404       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8405       s2d = scalar2(b1(1,itk),vtemp1d(1))
8406 #ifdef MOMENT
8407       call transpose2(AEA(1,1,2),atempd(1,1))
8408       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8409       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8410 #else
8411       s8d = 0.0d0
8412 #endif
8413       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8414       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8415 #ifdef MOMENT
8416       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8417       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8418       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8419 #else
8420       s13d = 0.0d0
8421 #endif
8422 c      s1d=0.0d0
8423 c      s2d=0.0d0
8424 c      s8d=0.0d0
8425 c      s12d=0.0d0
8426 c      s13d=0.0d0
8427 #ifdef MOMENT
8428       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8429      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8430 #else
8431       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8432      &               -0.5d0*ekont*(s2d+s12d)
8433 #endif
8434 C Cartesian derivatives
8435       do iii=1,2
8436         do kkk=1,5
8437           do lll=1,3
8438 #ifdef MOMENT
8439             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8440             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8441             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8442 #else
8443             s1d = 0.0d0
8444 #endif
8445             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8446             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8447      &          vtemp1d(1))
8448             s2d = scalar2(b1(1,itk),vtemp1d(1))
8449 #ifdef MOMENT
8450             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8451             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8452             s8d = -(atempd(1,1)+atempd(2,2))*
8453      &           scalar2(cc(1,1,itl),vtemp2(1))
8454 #else
8455             s8d = 0.0d0
8456 #endif
8457             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8458      &           auxmatd(1,1))
8459             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8460             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8461 c      s1d=0.0d0
8462 c      s2d=0.0d0
8463 c      s8d=0.0d0
8464 c      s12d=0.0d0
8465 c      s13d=0.0d0
8466 #ifdef MOMENT
8467             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8468      &        - 0.5d0*(s1d+s2d)
8469 #else
8470             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8471      &        - 0.5d0*s2d
8472 #endif
8473 #ifdef MOMENT
8474             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8475      &        - 0.5d0*(s8d+s12d)
8476 #else
8477             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8478      &        - 0.5d0*s12d
8479 #endif
8480           enddo
8481         enddo
8482       enddo
8483 #ifdef MOMENT
8484       do kkk=1,5
8485         do lll=1,3
8486           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8487      &      achuj_tempd(1,1))
8488           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8489           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8490           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8491           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8492           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8493      &      vtemp4d(1))
8494           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8495           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8496           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8497         enddo
8498       enddo
8499 #endif
8500 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8501 cd     &  16*eel_turn6_num
8502 cd      goto 1112
8503       if (j.lt.nres-1) then
8504         j1=j+1
8505         j2=j-1
8506       else
8507         j1=j-1
8508         j2=j-2
8509       endif
8510       if (l.lt.nres-1) then
8511         l1=l+1
8512         l2=l-1
8513       else
8514         l1=l-1
8515         l2=l-2
8516       endif
8517       do ll=1,3
8518         ggg1(ll)=eel_turn6*g_contij(ll,1)
8519         ggg2(ll)=eel_turn6*g_contij(ll,2)
8520         ghalf=0.5d0*ggg1(ll)
8521 cd        ghalf=0.0d0
8522         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8523      &    +ekont*derx_turn(ll,2,1)
8524         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8525         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8526      &    +ekont*derx_turn(ll,4,1)
8527         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8528         ghalf=0.5d0*ggg2(ll)
8529 cd        ghalf=0.0d0
8530         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8531      &    +ekont*derx_turn(ll,2,2)
8532         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8533         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8534      &    +ekont*derx_turn(ll,4,2)
8535         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8536       enddo
8537 cd      goto 1112
8538       do m=i+1,j-1
8539         do ll=1,3
8540           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8541         enddo
8542       enddo
8543       do m=k+1,l-1
8544         do ll=1,3
8545           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8546         enddo
8547       enddo
8548 1112  continue
8549       do m=i+2,j2
8550         do ll=1,3
8551           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8552         enddo
8553       enddo
8554       do m=k+2,l2
8555         do ll=1,3
8556           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8557         enddo
8558       enddo
8559 cd      do iii=1,nres-3
8560 cd        write (2,*) iii,g_corr6_loc(iii)
8561 cd      enddo
8562       endif
8563       eello_turn6=ekont*eel_turn6
8564 cd      write (2,*) 'ekont',ekont
8565 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8566       return
8567       end
8568 crc-------------------------------------------------
8569 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8570       subroutine Eliptransfer(eliptran)
8571       implicit real*8 (a-h,o-z)
8572       include 'DIMENSIONS'
8573       include 'COMMON.GEO'
8574       include 'COMMON.VAR'
8575       include 'COMMON.LOCAL'
8576       include 'COMMON.CHAIN'
8577       include 'COMMON.DERIV'
8578       include 'COMMON.INTERACT'
8579       include 'COMMON.IOUNITS'
8580       include 'COMMON.CALC'
8581       include 'COMMON.CONTROL'
8582       include 'COMMON.SPLITELE'
8583       include 'COMMON.SBRIDGE'
8584 C this is done by Adasko
8585 C      print *,"wchodze"
8586 C structure of box:
8587 C      water
8588 C--bordliptop-- buffore starts
8589 C--bufliptop--- here true lipid starts
8590 C      lipid
8591 C--buflipbot--- lipid ends buffore starts
8592 C--bordlipbot--buffore ends
8593       eliptran=0.0
8594       do i=1,nres
8595 C       do i=1,1
8596         if (itype(i).eq.ntyp1) cycle
8597
8598         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8599         if (positi.le.0) positi=positi+boxzsize
8600 C        print *,i
8601 C first for peptide groups
8602 c for each residue check if it is in lipid or lipid water border area
8603        if ((positi.gt.bordlipbot)
8604      &.and.(positi.lt.bordliptop)) then
8605 C the energy transfer exist
8606         if (positi.lt.buflipbot) then
8607 C what fraction I am in
8608          fracinbuf=1.0d0-
8609      &        ((positi-bordlipbot)/lipbufthick)
8610 C lipbufthick is thickenes of lipid buffore
8611          sslip=sscalelip(fracinbuf)
8612          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8613          eliptran=eliptran+sslip*pepliptran
8614          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8615          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8616 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8617         elseif (positi.gt.bufliptop) then
8618          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8619          sslip=sscalelip(fracinbuf)
8620          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8621          eliptran=eliptran+sslip*pepliptran
8622          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8623          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8624 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8625 C          print *, "doing sscalefor top part"
8626 C         print *,i,sslip,fracinbuf,ssgradlip
8627         else
8628          eliptran=eliptran+pepliptran
8629 C         print *,"I am in true lipid"
8630         endif
8631 C       else
8632 C       eliptran=elpitran+0.0 ! I am in water
8633        endif
8634        enddo
8635 C       print *, "nic nie bylo w lipidzie?"
8636 C now multiply all by the peptide group transfer factor
8637 C       eliptran=eliptran*pepliptran
8638 C now the same for side chains
8639 CV       do i=1,1
8640        do i=1,nres
8641         if (itype(i).eq.ntyp1) cycle
8642         positi=(mod(c(3,i+nres),boxzsize))
8643         if (positi.le.0) positi=positi+boxzsize
8644 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8645 c for each residue check if it is in lipid or lipid water border area
8646 C       respos=mod(c(3,i+nres),boxzsize)
8647 C       print *,positi,bordlipbot,buflipbot
8648        if ((positi.gt.bordlipbot)
8649      & .and.(positi.lt.bordliptop)) then
8650 C the energy transfer exist
8651         if (positi.lt.buflipbot) then
8652          fracinbuf=1.0d0-
8653      &     ((positi-bordlipbot)/lipbufthick)
8654 C lipbufthick is thickenes of lipid buffore
8655          sslip=sscalelip(fracinbuf)
8656          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8657          eliptran=eliptran+sslip*liptranene(itype(i))
8658          gliptranx(3,i)=gliptranx(3,i)
8659      &+ssgradlip*liptranene(itype(i))
8660          gliptranc(3,i-1)= gliptranc(3,i-1)
8661      &+ssgradlip*liptranene(itype(i))
8662 C         print *,"doing sccale for lower part"
8663         elseif (positi.gt.bufliptop) then
8664          fracinbuf=1.0d0-
8665      &((bordliptop-positi)/lipbufthick)
8666          sslip=sscalelip(fracinbuf)
8667          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8668          eliptran=eliptran+sslip*liptranene(itype(i))
8669          gliptranx(3,i)=gliptranx(3,i)
8670      &+ssgradlip*liptranene(itype(i))
8671          gliptranc(3,i-1)= gliptranc(3,i-1)
8672      &+ssgradlip*liptranene(itype(i))
8673 C          print *, "doing sscalefor top part",sslip,fracinbuf
8674         else
8675          eliptran=eliptran+liptranene(itype(i))
8676 C         print *,"I am in true lipid"
8677         endif
8678         endif ! if in lipid or buffor
8679 C       else
8680 C       eliptran=elpitran+0.0 ! I am in water
8681        enddo
8682        return
8683        end
8684
8685
8686 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8687
8688       SUBROUTINE MATVEC2(A1,V1,V2)
8689       implicit real*8 (a-h,o-z)
8690       include 'DIMENSIONS'
8691       DIMENSION A1(2,2),V1(2),V2(2)
8692 c      DO 1 I=1,2
8693 c        VI=0.0
8694 c        DO 3 K=1,2
8695 c    3     VI=VI+A1(I,K)*V1(K)
8696 c        Vaux(I)=VI
8697 c    1 CONTINUE
8698
8699       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8700       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8701
8702       v2(1)=vaux1
8703       v2(2)=vaux2
8704       END
8705 C---------------------------------------
8706       SUBROUTINE MATMAT2(A1,A2,A3)
8707       implicit real*8 (a-h,o-z)
8708       include 'DIMENSIONS'
8709       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8710 c      DIMENSION AI3(2,2)
8711 c        DO  J=1,2
8712 c          A3IJ=0.0
8713 c          DO K=1,2
8714 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8715 c          enddo
8716 c          A3(I,J)=A3IJ
8717 c       enddo
8718 c      enddo
8719
8720       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8721       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8722       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8723       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8724
8725       A3(1,1)=AI3_11
8726       A3(2,1)=AI3_21
8727       A3(1,2)=AI3_12
8728       A3(2,2)=AI3_22
8729       END
8730
8731 c-------------------------------------------------------------------------
8732       double precision function scalar2(u,v)
8733       implicit none
8734       double precision u(2),v(2)
8735       double precision sc
8736       integer i
8737       scalar2=u(1)*v(1)+u(2)*v(2)
8738       return
8739       end
8740
8741 C-----------------------------------------------------------------------------
8742
8743       subroutine transpose2(a,at)
8744       implicit none
8745       double precision a(2,2),at(2,2)
8746       at(1,1)=a(1,1)
8747       at(1,2)=a(2,1)
8748       at(2,1)=a(1,2)
8749       at(2,2)=a(2,2)
8750       return
8751       end
8752 c--------------------------------------------------------------------------
8753       subroutine transpose(n,a,at)
8754       implicit none
8755       integer n,i,j
8756       double precision a(n,n),at(n,n)
8757       do i=1,n
8758         do j=1,n
8759           at(j,i)=a(i,j)
8760         enddo
8761       enddo
8762       return
8763       end
8764 C---------------------------------------------------------------------------
8765       subroutine prodmat3(a1,a2,kk,transp,prod)
8766       implicit none
8767       integer i,j
8768       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8769       logical transp
8770 crc      double precision auxmat(2,2),prod_(2,2)
8771
8772       if (transp) then
8773 crc        call transpose2(kk(1,1),auxmat(1,1))
8774 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8775 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8776
8777            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8778      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8779            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8780      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8781            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8782      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8783            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8784      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8785
8786       else
8787 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8788 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8789
8790            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8791      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8792            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8793      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8794            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8795      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8796            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8797      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8798
8799       endif
8800 c      call transpose2(a2(1,1),a2t(1,1))
8801
8802 crc      print *,transp
8803 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8804 crc      print *,((prod(i,j),i=1,2),j=1,2)
8805
8806       return
8807       end
8808 C-----------------------------------------------------------------------------
8809       double precision function scalar(u,v)
8810       implicit none
8811       double precision u(3),v(3)
8812       double precision sc
8813       integer i
8814       sc=0.0d0
8815       do i=1,3
8816         sc=sc+u(i)*v(i)
8817       enddo
8818       scalar=sc
8819       return
8820       end
8821 C-----------------------------------------------------------------------
8822       double precision function sscale(r)
8823       double precision r,gamm
8824       include "COMMON.SPLITELE"
8825       if(r.lt.r_cut-rlamb) then
8826         sscale=1.0d0
8827       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8828         gamm=(r-(r_cut-rlamb))/rlamb
8829         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8830       else
8831         sscale=0d0
8832       endif
8833       return
8834       end
8835 C-----------------------------------------------------------------------
8836 C-----------------------------------------------------------------------
8837       double precision function sscagrad(r)
8838       double precision r,gamm
8839       include "COMMON.SPLITELE"
8840       if(r.lt.r_cut-rlamb) then
8841         sscagrad=0.0d0
8842       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8843         gamm=(r-(r_cut-rlamb))/rlamb
8844         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8845       else
8846         sscagrad=0.0d0
8847       endif
8848       return
8849       end
8850 C-----------------------------------------------------------------------
8851 C-----------------------------------------------------------------------
8852       double precision function sscalelip(r)
8853       double precision r,gamm
8854       include "COMMON.SPLITELE"
8855 C      if(r.lt.r_cut-rlamb) then
8856 C        sscale=1.0d0
8857 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8858 C        gamm=(r-(r_cut-rlamb))/rlamb
8859         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8860 C      else
8861 C        sscale=0d0
8862 C      endif
8863       return
8864       end
8865 C-----------------------------------------------------------------------
8866       double precision function sscagradlip(r)
8867       double precision r,gamm
8868       include "COMMON.SPLITELE"
8869 C     if(r.lt.r_cut-rlamb) then
8870 C        sscagrad=0.0d0
8871 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8872 C        gamm=(r-(r_cut-rlamb))/rlamb
8873         sscagradlip=r*(6*r-6.0d0)
8874 C      else
8875 C        sscagrad=0.0d0
8876 C      endif
8877       return
8878       end
8879
8880 C-----------------------------------------------------------------------
8881        subroutine set_shield_fac
8882       implicit real*8 (a-h,o-z)
8883       include 'DIMENSIONS'
8884       include 'COMMON.CHAIN'
8885       include 'COMMON.DERIV'
8886       include 'COMMON.IOUNITS'
8887       include 'COMMON.SHIELD'
8888       include 'COMMON.INTERACT'
8889 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
8890       double precision div77_81/0.974996043d0/,
8891      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
8892
8893 C the vector between center of side_chain and peptide group
8894        double precision pep_side(3),long,side_calf(3),
8895      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
8896      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
8897 C the line belowe needs to be changed for FGPROC>1
8898       do i=1,nres-1
8899       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
8900       ishield_list(i)=0
8901 Cif there two consequtive dummy atoms there is no peptide group between them
8902 C the line below has to be changed for FGPROC>1
8903       VolumeTotal=0.0
8904       do k=1,nres
8905        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
8906        dist_pep_side=0.0
8907        dist_side_calf=0.0
8908        do j=1,3
8909 C first lets set vector conecting the ithe side-chain with kth side-chain
8910       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
8911 C      pep_side(j)=2.0d0
8912 C and vector conecting the side-chain with its proper calfa
8913       side_calf(j)=c(j,k+nres)-c(j,k)
8914 C      side_calf(j)=2.0d0
8915       pept_group(j)=c(j,i)-c(j,i+1)
8916 C lets have their lenght
8917       dist_pep_side=pep_side(j)**2+dist_pep_side
8918       dist_side_calf=dist_side_calf+side_calf(j)**2
8919       dist_pept_group=dist_pept_group+pept_group(j)**2
8920       enddo
8921        dist_pep_side=dsqrt(dist_pep_side)
8922        dist_pept_group=dsqrt(dist_pept_group)
8923        dist_side_calf=dsqrt(dist_side_calf)
8924       do j=1,3
8925         pep_side_norm(j)=pep_side(j)/dist_pep_side
8926         side_calf_norm(j)=dist_side_calf
8927       enddo
8928 C now sscale fraction
8929        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
8930 C       print *,buff_shield,"buff"
8931 C now sscale
8932         if (sh_frac_dist.le.0.0) cycle
8933 C If we reach here it means that this side chain reaches the shielding sphere
8934 C Lets add him to the list for gradient
8935         ishield_list(i)=ishield_list(i)+1
8936 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
8937 C this list is essential otherwise problem would be O3
8938         shield_list(ishield_list(i),i)=k
8939 C Lets have the sscale value
8940         if (sh_frac_dist.gt.1.0) then
8941          scale_fac_dist=1.0d0
8942          do j=1,3
8943          sh_frac_dist_grad(j)=0.0d0
8944          enddo
8945         else
8946          scale_fac_dist=-sh_frac_dist*sh_frac_dist
8947      &                   *(2.0*sh_frac_dist-3.0d0)
8948          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
8949      &                  /dist_pep_side/buff_shield*0.5
8950 C remember for the final gradient multiply sh_frac_dist_grad(j)
8951 C for side_chain by factor -2 !
8952          do j=1,3
8953          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
8954 C         print *,"jestem",scale_fac_dist,fac_help_scale,
8955 C     &                    sh_frac_dist_grad(j)
8956          enddo
8957         endif
8958 C        if ((i.eq.3).and.(k.eq.2)) then
8959 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
8960 C     & ,"TU"
8961 C        endif
8962
8963 C this is what is now we have the distance scaling now volume...
8964       short=short_r_sidechain(itype(k))
8965       long=long_r_sidechain(itype(k))
8966       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
8967 C now costhet_grad
8968 C       costhet=0.0d0
8969        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
8970 C       costhet_fac=0.0d0
8971        do j=1,3
8972          costhet_grad(j)=costhet_fac*pep_side(j)
8973        enddo
8974 C remember for the final gradient multiply costhet_grad(j)
8975 C for side_chain by factor -2 !
8976 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
8977 C pep_side0pept_group is vector multiplication
8978       pep_side0pept_group=0.0
8979       do j=1,3
8980       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
8981       enddo
8982       cosalfa=(pep_side0pept_group/
8983      & (dist_pep_side*dist_side_calf))
8984       fac_alfa_sin=1.0-cosalfa**2
8985       fac_alfa_sin=dsqrt(fac_alfa_sin)
8986       rkprim=fac_alfa_sin*(long-short)+short
8987 C now costhet_grad
8988        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
8989        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
8990
8991        do j=1,3
8992          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
8993      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
8994      &*(long-short)/fac_alfa_sin*cosalfa/
8995      &((dist_pep_side*dist_side_calf))*
8996      &((side_calf(j))-cosalfa*
8997      &((pep_side(j)/dist_pep_side)*dist_side_calf))
8998
8999         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9000      &*(long-short)/fac_alfa_sin*cosalfa
9001      &/((dist_pep_side*dist_side_calf))*
9002      &(pep_side(j)-
9003      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9004        enddo
9005
9006       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9007      &                    /VSolvSphere_div
9008      &                    *wshield
9009 C now the gradient...
9010 C grad_shield is gradient of Calfa for peptide groups
9011 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9012 C     &               costhet,cosphi
9013 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9014 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9015       do j=1,3
9016       grad_shield(j,i)=grad_shield(j,i)
9017 C gradient po skalowaniu
9018      &                +(sh_frac_dist_grad(j)
9019 C  gradient po costhet
9020      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9021      &-scale_fac_dist*(cosphi_grad_long(j))
9022      &/(1.0-cosphi) )*div77_81
9023      &*VofOverlap
9024 C grad_shield_side is Cbeta sidechain gradient
9025       grad_shield_side(j,ishield_list(i),i)=
9026      &        (sh_frac_dist_grad(j)*-2.0d0
9027      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9028      &       +scale_fac_dist*(cosphi_grad_long(j))
9029      &        *2.0d0/(1.0-cosphi))
9030      &        *div77_81*VofOverlap
9031
9032        grad_shield_loc(j,ishield_list(i),i)=
9033      &   scale_fac_dist*cosphi_grad_loc(j)
9034      &        *2.0d0/(1.0-cosphi)
9035      &        *div77_81*VofOverlap
9036       enddo
9037       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9038       enddo
9039       fac_shield(i)=VolumeTotal*div77_81+div4_81
9040 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9041       enddo
9042       return
9043       end
9044 C--------------------------------------------------------------------------
9045 C first for shielding is setting of function of side-chains
9046        subroutine set_shield_fac2
9047       implicit real*8 (a-h,o-z)
9048       include 'DIMENSIONS'
9049       include 'COMMON.CHAIN'
9050       include 'COMMON.DERIV'
9051       include 'COMMON.IOUNITS'
9052       include 'COMMON.SHIELD'
9053       include 'COMMON.INTERACT'
9054 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9055       double precision div77_81/0.974996043d0/,
9056      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9057
9058 C the vector between center of side_chain and peptide group
9059        double precision pep_side(3),long,side_calf(3),
9060      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9061      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9062 C the line belowe needs to be changed for FGPROC>1
9063       do i=1,nres-1
9064       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9065       ishield_list(i)=0
9066 Cif there two consequtive dummy atoms there is no peptide group between them
9067 C the line below has to be changed for FGPROC>1
9068       VolumeTotal=0.0
9069       do k=1,nres
9070        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9071        dist_pep_side=0.0
9072        dist_side_calf=0.0
9073        do j=1,3
9074 C first lets set vector conecting the ithe side-chain with kth side-chain
9075       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9076 C      pep_side(j)=2.0d0
9077 C and vector conecting the side-chain with its proper calfa
9078       side_calf(j)=c(j,k+nres)-c(j,k)
9079 C      side_calf(j)=2.0d0
9080       pept_group(j)=c(j,i)-c(j,i+1)
9081 C lets have their lenght
9082       dist_pep_side=pep_side(j)**2+dist_pep_side
9083       dist_side_calf=dist_side_calf+side_calf(j)**2
9084       dist_pept_group=dist_pept_group+pept_group(j)**2
9085       enddo
9086        dist_pep_side=dsqrt(dist_pep_side)
9087        dist_pept_group=dsqrt(dist_pept_group)
9088        dist_side_calf=dsqrt(dist_side_calf)
9089       do j=1,3
9090         pep_side_norm(j)=pep_side(j)/dist_pep_side
9091         side_calf_norm(j)=dist_side_calf
9092       enddo
9093 C now sscale fraction
9094        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9095 C       print *,buff_shield,"buff"
9096 C now sscale
9097         if (sh_frac_dist.le.0.0) cycle
9098 C If we reach here it means that this side chain reaches the shielding sphere
9099 C Lets add him to the list for gradient
9100         ishield_list(i)=ishield_list(i)+1
9101 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9102 C this list is essential otherwise problem would be O3
9103         shield_list(ishield_list(i),i)=k
9104 C Lets have the sscale value
9105         if (sh_frac_dist.gt.1.0) then
9106          scale_fac_dist=1.0d0
9107          do j=1,3
9108          sh_frac_dist_grad(j)=0.0d0
9109          enddo
9110         else
9111          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9112      &                   *(2.0d0*sh_frac_dist-3.0d0)
9113          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9114      &                  /dist_pep_side/buff_shield*0.5d0
9115 C remember for the final gradient multiply sh_frac_dist_grad(j)
9116 C for side_chain by factor -2 !
9117          do j=1,3
9118          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9119 C         sh_frac_dist_grad(j)=0.0d0
9120 C         scale_fac_dist=1.0d0
9121 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9122 C     &                    sh_frac_dist_grad(j)
9123          enddo
9124         endif
9125 C this is what is now we have the distance scaling now volume...
9126       short=short_r_sidechain(itype(k))
9127       long=long_r_sidechain(itype(k))
9128       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9129       sinthet=short/dist_pep_side*costhet
9130 C now costhet_grad
9131 C       costhet=0.6d0
9132 C       sinthet=0.8
9133        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9134 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9135 C     &             -short/dist_pep_side**2/costhet)
9136 C       costhet_fac=0.0d0
9137        do j=1,3
9138          costhet_grad(j)=costhet_fac*pep_side(j)
9139        enddo
9140 C remember for the final gradient multiply costhet_grad(j)
9141 C for side_chain by factor -2 !
9142 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9143 C pep_side0pept_group is vector multiplication
9144       pep_side0pept_group=0.0d0
9145       do j=1,3
9146       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9147       enddo
9148       cosalfa=(pep_side0pept_group/
9149      & (dist_pep_side*dist_side_calf))
9150       fac_alfa_sin=1.0d0-cosalfa**2
9151       fac_alfa_sin=dsqrt(fac_alfa_sin)
9152       rkprim=fac_alfa_sin*(long-short)+short
9153 C      rkprim=short
9154
9155 C now costhet_grad
9156        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9157 C       cosphi=0.6
9158        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9159        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9160      &      dist_pep_side**2)
9161 C       sinphi=0.8
9162        do j=1,3
9163          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9164      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9165      &*(long-short)/fac_alfa_sin*cosalfa/
9166      &((dist_pep_side*dist_side_calf))*
9167      &((side_calf(j))-cosalfa*
9168      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9169 C       cosphi_grad_long(j)=0.0d0
9170         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9171      &*(long-short)/fac_alfa_sin*cosalfa
9172      &/((dist_pep_side*dist_side_calf))*
9173      &(pep_side(j)-
9174      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9175 C       cosphi_grad_loc(j)=0.0d0
9176        enddo
9177 C      print *,sinphi,sinthet
9178       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9179      &                    /VSolvSphere_div
9180 C     &                    *wshield
9181 C now the gradient...
9182       do j=1,3
9183       grad_shield(j,i)=grad_shield(j,i)
9184 C gradient po skalowaniu
9185      &                +(sh_frac_dist_grad(j)*VofOverlap
9186 C  gradient po costhet
9187      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9188      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9189      &       sinphi/sinthet*costhet*costhet_grad(j)
9190      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9191      & )*wshield
9192 C grad_shield_side is Cbeta sidechain gradient
9193       grad_shield_side(j,ishield_list(i),i)=
9194      &        (sh_frac_dist_grad(j)*-2.0d0
9195      &        *VofOverlap
9196      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9197      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9198      &       sinphi/sinthet*costhet*costhet_grad(j)
9199      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9200      &       )*wshield
9201
9202        grad_shield_loc(j,ishield_list(i),i)=
9203      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9204      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9205      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9206      &        ))
9207      &        *wshield
9208       enddo
9209       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9210       enddo
9211       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9212 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9213 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9214       enddo
9215       return
9216       end
9217
9218 C-----------------------------------------------------------------------
9219 C-----------------------------------------------------------
9220 C This subroutine is to mimic the histone like structure but as well can be
9221 C utilizet to nanostructures (infinit) small modification has to be used to
9222 C make it finite (z gradient at the ends has to be changes as well as the x,y
9223 C gradient has to be modified at the ends
9224 C The energy function is Kihara potential
9225 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9226 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9227 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9228 C simple Kihara potential
9229       subroutine calctube(Etube)
9230        implicit real*8 (a-h,o-z)
9231       include 'DIMENSIONS'
9232       include 'COMMON.GEO'
9233       include 'COMMON.VAR'
9234       include 'COMMON.LOCAL'
9235       include 'COMMON.CHAIN'
9236       include 'COMMON.DERIV'
9237       include 'COMMON.INTERACT'
9238       include 'COMMON.IOUNITS'
9239       include 'COMMON.CALC'
9240       include 'COMMON.CONTROL'
9241       include 'COMMON.SPLITELE'
9242       include 'COMMON.SBRIDGE'
9243       double precision tub_r,vectube(3),enetube(maxres*2)
9244       Etube=0.0d0
9245       do i=itube_start,itube_end
9246         enetube(i)=0.0d0
9247         enetube(i+nres)=0.0d0
9248       enddo
9249 C first we calculate the distance from tube center
9250 C first sugare-phosphate group for NARES this would be peptide group
9251 C for UNRES
9252        do i=itube_start,itube_end
9253 C lets ommit dummy atoms for now
9254        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9255 C now calculate distance from center of tube and direction vectors
9256       xmin=boxxsize
9257       ymin=boxysize
9258         do j=-1,1
9259          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9260          vectube(1)=vectube(1)+boxxsize*j
9261          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9262          vectube(2)=vectube(2)+boxysize*j
9263
9264          xminact=abs(vectube(1)-tubecenter(1))
9265          yminact=abs(vectube(2)-tubecenter(2))
9266            if (xmin.gt.xminact) then
9267             xmin=xminact
9268             xtemp=vectube(1)
9269            endif
9270            if (ymin.gt.yminact) then
9271              ymin=yminact
9272              ytemp=vectube(2)
9273             endif
9274          enddo
9275       vectube(1)=xtemp
9276       vectube(2)=ytemp
9277       vectube(1)=vectube(1)-tubecenter(1)
9278       vectube(2)=vectube(2)-tubecenter(2)
9279
9280 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9281 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9282
9283 C as the tube is infinity we do not calculate the Z-vector use of Z
9284 C as chosen axis
9285       vectube(3)=0.0d0
9286 C now calculte the distance
9287        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9288 C now normalize vector
9289       vectube(1)=vectube(1)/tub_r
9290       vectube(2)=vectube(2)/tub_r
9291 C calculte rdiffrence between r and r0
9292       rdiff=tub_r-tubeR0
9293 C and its 6 power
9294       rdiff6=rdiff**6.0d0
9295 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9296        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
9297 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9298 C       print *,rdiff,rdiff6,pep_aa_tube
9299 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9300 C now we calculate gradient
9301        fac=(-12.0d0*pep_aa_tube/rdiff6-
9302      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
9303 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9304 C     &rdiff,fac
9305
9306 C now direction of gg_tube vector
9307         do j=1,3
9308         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9309         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9310         enddo
9311         enddo
9312 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
9313 C        print *,gg_tube(1,0),"TU"
9314
9315
9316        do i=itube_start,itube_end
9317 C Lets not jump over memory as we use many times iti
9318          iti=itype(i)
9319 C lets ommit dummy atoms for now
9320          if ((iti.eq.ntyp1)
9321 C in UNRES uncomment the line below as GLY has no side-chain...
9322 C      .or.(iti.eq.10)
9323      &   ) cycle
9324       xmin=boxxsize
9325       ymin=boxysize
9326         do j=-1,1
9327          vectube(1)=mod((c(1,i+nres)),boxxsize)
9328          vectube(1)=vectube(1)+boxxsize*j
9329          vectube(2)=mod((c(2,i+nres)),boxysize)
9330          vectube(2)=vectube(2)+boxysize*j
9331
9332          xminact=abs(vectube(1)-tubecenter(1))
9333          yminact=abs(vectube(2)-tubecenter(2))
9334            if (xmin.gt.xminact) then
9335             xmin=xminact
9336             xtemp=vectube(1)
9337            endif
9338            if (ymin.gt.yminact) then
9339              ymin=yminact
9340              ytemp=vectube(2)
9341             endif
9342          enddo
9343       vectube(1)=xtemp
9344       vectube(2)=ytemp
9345 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
9346 C     &     tubecenter(2)
9347       vectube(1)=vectube(1)-tubecenter(1)
9348       vectube(2)=vectube(2)-tubecenter(2)
9349
9350 C as the tube is infinity we do not calculate the Z-vector use of Z
9351 C as chosen axis
9352       vectube(3)=0.0d0
9353 C now calculte the distance
9354        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9355 C now normalize vector
9356       vectube(1)=vectube(1)/tub_r
9357       vectube(2)=vectube(2)/tub_r
9358
9359 C calculte rdiffrence between r and r0
9360       rdiff=tub_r-tubeR0
9361 C and its 6 power
9362       rdiff6=rdiff**6.0d0
9363 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9364        sc_aa_tube=sc_aa_tube_par(iti)
9365        sc_bb_tube=sc_bb_tube_par(iti)
9366        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
9367 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9368 C now we calculate gradient
9369        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9370      &       6.0d0*sc_bb_tube/rdiff6/rdiff
9371 C now direction of gg_tube vector
9372          do j=1,3
9373           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9374           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9375          enddo
9376         enddo
9377         do i=itube_start,itube_end
9378           Etube=Etube+enetube(i)+enetube(i+nres)
9379         enddo
9380 C        print *,"ETUBE", etube
9381         return
9382         end
9383 C TO DO 1) add to total energy
9384 C       2) add to gradient summation
9385 C       3) add reading parameters (AND of course oppening of PARAM file)
9386 C       4) add reading the center of tube
9387 C       5) add COMMONs
9388 C       6) add to zerograd
9389
9390 C-----------------------------------------------------------------------
9391 C-----------------------------------------------------------
9392 C This subroutine is to mimic the histone like structure but as well can be
9393 C utilizet to nanostructures (infinit) small modification has to be used to
9394 C make it finite (z gradient at the ends has to be changes as well as the x,y
9395 C gradient has to be modified at the ends
9396 C The energy function is Kihara potential
9397 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9398 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9399 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9400 C simple Kihara potential
9401       subroutine calctube2(Etube)
9402        implicit real*8 (a-h,o-z)
9403       include 'DIMENSIONS'
9404       include 'COMMON.GEO'
9405       include 'COMMON.VAR'
9406       include 'COMMON.LOCAL'
9407       include 'COMMON.CHAIN'
9408       include 'COMMON.DERIV'
9409       include 'COMMON.INTERACT'
9410       include 'COMMON.IOUNITS'
9411       include 'COMMON.CALC'
9412       include 'COMMON.CONTROL'
9413       include 'COMMON.SPLITELE'
9414       include 'COMMON.SBRIDGE'
9415       double precision tub_r,vectube(3),enetube(maxres*2)
9416       Etube=0.0d0
9417       do i=itube_start,itube_end
9418         enetube(i)=0.0d0
9419         enetube(i+nres)=0.0d0
9420       enddo
9421 C first we calculate the distance from tube center
9422 C first sugare-phosphate group for NARES this would be peptide group
9423 C for UNRES
9424        do i=itube_start,itube_end
9425 C lets ommit dummy atoms for now
9426
9427        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9428 C now calculate distance from center of tube and direction vectors
9429 C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9430 C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
9431 C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9432 C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
9433       xmin=boxxsize
9434       ymin=boxysize
9435         do j=-1,1
9436          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9437          vectube(1)=vectube(1)+boxxsize*j
9438          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9439          vectube(2)=vectube(2)+boxysize*j
9440
9441          xminact=abs(vectube(1)-tubecenter(1))
9442          yminact=abs(vectube(2)-tubecenter(2))
9443            if (xmin.gt.xminact) then
9444             xmin=xminact
9445             xtemp=vectube(1)
9446            endif
9447            if (ymin.gt.yminact) then
9448              ymin=yminact
9449              ytemp=vectube(2)
9450             endif
9451          enddo
9452       vectube(1)=xtemp
9453       vectube(2)=ytemp
9454       vectube(1)=vectube(1)-tubecenter(1)
9455       vectube(2)=vectube(2)-tubecenter(2)
9456
9457 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9458 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9459
9460 C as the tube is infinity we do not calculate the Z-vector use of Z
9461 C as chosen axis
9462       vectube(3)=0.0d0
9463 C now calculte the distance
9464        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9465 C now normalize vector
9466       vectube(1)=vectube(1)/tub_r
9467       vectube(2)=vectube(2)/tub_r
9468 C calculte rdiffrence between r and r0
9469       rdiff=tub_r-tubeR0
9470 C and its 6 power
9471       rdiff6=rdiff**6.0d0
9472 C THIS FRAGMENT MAKES TUBE FINITE
9473         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
9474         if (positi.le.0) positi=positi+boxzsize
9475 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9476 c for each residue check if it is in lipid or lipid water border area
9477 C       respos=mod(c(3,i+nres),boxzsize)
9478        print *,positi,bordtubebot,buftubebot,bordtubetop
9479        if ((positi.gt.bordtubebot)
9480      & .and.(positi.lt.bordtubetop)) then
9481 C the energy transfer exist
9482         if (positi.lt.buftubebot) then
9483          fracinbuf=1.0d0-
9484      &     ((positi-bordtubebot)/tubebufthick)
9485 C lipbufthick is thickenes of lipid buffore
9486          sstube=sscalelip(fracinbuf)
9487          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
9488          print *,ssgradtube, sstube,tubetranene(itype(i))
9489          enetube(i)=enetube(i)+sstube*tubetranenepep
9490 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9491 C     &+ssgradtube*tubetranene(itype(i))
9492 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9493 C     &+ssgradtube*tubetranene(itype(i))
9494 C         print *,"doing sccale for lower part"
9495         elseif (positi.gt.buftubetop) then
9496          fracinbuf=1.0d0-
9497      &((bordtubetop-positi)/tubebufthick)
9498          sstube=sscalelip(fracinbuf)
9499          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
9500          enetube(i)=enetube(i)+sstube*tubetranenepep
9501 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9502 C     &+ssgradtube*tubetranene(itype(i))
9503 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9504 C     &+ssgradtube*tubetranene(itype(i))
9505 C          print *, "doing sscalefor top part",sslip,fracinbuf
9506         else
9507          sstube=1.0d0
9508          ssgradtube=0.0d0
9509          enetube(i)=enetube(i)+sstube*tubetranenepep
9510 C         print *,"I am in true lipid"
9511         endif
9512         else
9513 C          sstube=0.0d0
9514 C          ssgradtube=0.0d0
9515         cycle
9516         endif ! if in lipid or buffor
9517
9518 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9519        enetube(i)=enetube(i)+sstube*
9520      &(pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
9521 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9522 C       print *,rdiff,rdiff6,pep_aa_tube
9523 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9524 C now we calculate gradient
9525        fac=(-12.0d0*pep_aa_tube/rdiff6-
9526      &       6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
9527 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9528 C     &rdiff,fac
9529
9530 C now direction of gg_tube vector
9531         do j=1,3
9532         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9533         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9534         enddo
9535          gg_tube(3,i)=gg_tube(3,i)
9536      &+ssgradtube*enetube(i)/sstube/2.0d0
9537          gg_tube(3,i-1)= gg_tube(3,i-1)
9538      &+ssgradtube*enetube(i)/sstube/2.0d0
9539
9540         enddo
9541 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
9542 C        print *,gg_tube(1,0),"TU"
9543         do i=itube_start,itube_end
9544 C Lets not jump over memory as we use many times iti
9545          iti=itype(i)
9546 C lets ommit dummy atoms for now
9547          if ((iti.eq.ntyp1)
9548 C in UNRES uncomment the line below as GLY has no side-chain...
9549      &      .or.(iti.eq.10)
9550      &   ) cycle
9551           vectube(1)=c(1,i+nres)
9552           vectube(1)=mod(vectube(1),boxxsize)
9553           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
9554           vectube(2)=c(2,i+nres)
9555           vectube(2)=mod(vectube(2),boxysize)
9556           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
9557
9558       vectube(1)=vectube(1)-tubecenter(1)
9559       vectube(2)=vectube(2)-tubecenter(2)
9560 C THIS FRAGMENT MAKES TUBE FINITE
9561         positi=(mod(c(3,i+nres),boxzsize))
9562         if (positi.le.0) positi=positi+boxzsize
9563 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9564 c for each residue check if it is in lipid or lipid water border area
9565 C       respos=mod(c(3,i+nres),boxzsize)
9566        print *,positi,bordtubebot,buftubebot,bordtubetop
9567        if ((positi.gt.bordtubebot)
9568      & .and.(positi.lt.bordtubetop)) then
9569 C the energy transfer exist
9570         if (positi.lt.buftubebot) then
9571          fracinbuf=1.0d0-
9572      &     ((positi-bordtubebot)/tubebufthick)
9573 C lipbufthick is thickenes of lipid buffore
9574          sstube=sscalelip(fracinbuf)
9575          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
9576          print *,ssgradtube, sstube,tubetranene(itype(i))
9577          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9578 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9579 C     &+ssgradtube*tubetranene(itype(i))
9580 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9581 C     &+ssgradtube*tubetranene(itype(i))
9582 C         print *,"doing sccale for lower part"
9583         elseif (positi.gt.buftubetop) then
9584          fracinbuf=1.0d0-
9585      &((bordtubetop-positi)/tubebufthick)
9586          sstube=sscalelip(fracinbuf)
9587          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
9588          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9589 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
9590 C     &+ssgradtube*tubetranene(itype(i))
9591 C         gg_tube(3,i-1)= gg_tube(3,i-1)
9592 C     &+ssgradtube*tubetranene(itype(i))
9593 C          print *, "doing sscalefor top part",sslip,fracinbuf
9594         else
9595          sstube=1.0d0
9596          ssgradtube=0.0d0
9597          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
9598 C         print *,"I am in true lipid"
9599         endif
9600         else
9601 C          sstube=0.0d0
9602 C          ssgradtube=0.0d0
9603         cycle
9604         endif ! if in lipid or buffor
9605 CEND OF FINITE FRAGMENT
9606 C as the tube is infinity we do not calculate the Z-vector use of Z
9607 C as chosen axis
9608       vectube(3)=0.0d0
9609 C now calculte the distance
9610        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9611 C now normalize vector
9612       vectube(1)=vectube(1)/tub_r
9613       vectube(2)=vectube(2)/tub_r
9614 C calculte rdiffrence between r and r0
9615       rdiff=tub_r-tubeR0
9616 C and its 6 power
9617       rdiff6=rdiff**6.0d0
9618 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9619        sc_aa_tube=sc_aa_tube_par(iti)
9620        sc_bb_tube=sc_bb_tube_par(iti)
9621        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
9622      &                 *sstube+enetube(i+nres)
9623 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9624 C now we calculate gradient
9625        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9626      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
9627 C now direction of gg_tube vector
9628          do j=1,3
9629           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9630           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9631          enddo
9632          gg_tube_SC(3,i)=gg_tube_SC(3,i)
9633      &+ssgradtube*enetube(i+nres)/sstube
9634          gg_tube(3,i-1)= gg_tube(3,i-1)
9635      &+ssgradtube*enetube(i+nres)/sstube
9636
9637         enddo
9638         do i=itube_start,itube_end
9639           Etube=Etube+enetube(i)+enetube(i+nres)
9640         enddo
9641 C        print *,"ETUBE", etube
9642         return
9643         end
9644 C TO DO 1) add to total energy
9645 C       2) add to gradient summation
9646 C       3) add reading parameters (AND of course oppening of PARAM file)
9647 C       4) add reading the center of tube
9648 C       5) add COMMONs
9649 C       6) add to zerograd
9650
9651
9652 C#-------------------------------------------------------------------------------
9653 C This subroutine is to mimic the histone like structure but as well can be
9654 C utilizet to nanostructures (infinit) small modification has to be used to
9655 C make it finite (z gradient at the ends has to be changes as well as the x,y
9656 C gradient has to be modified at the ends
9657 C The energy function is Kihara potential
9658 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
9659 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
9660 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
9661 C simple Kihara potential
9662       subroutine calcnano(Etube)
9663        implicit real*8 (a-h,o-z)
9664       include 'DIMENSIONS'
9665       include 'COMMON.GEO'
9666       include 'COMMON.VAR'
9667       include 'COMMON.LOCAL'
9668       include 'COMMON.CHAIN'
9669       include 'COMMON.DERIV'
9670       include 'COMMON.INTERACT'
9671       include 'COMMON.IOUNITS'
9672       include 'COMMON.CALC'
9673       include 'COMMON.CONTROL'
9674       include 'COMMON.SPLITELE'
9675       include 'COMMON.SBRIDGE'
9676       double precision tub_r,vectube(3),enetube(maxres*2),
9677      & enecavtube(maxres*2)
9678       Etube=0.0d0
9679       do i=itube_start,itube_end
9680         enetube(i)=0.0d0
9681         enetube(i+nres)=0.0d0
9682       enddo
9683 C first we calculate the distance from tube center
9684 C first sugare-phosphate group for NARES this would be peptide group
9685 C for UNRES
9686        do i=itube_start,itube_end
9687 C lets ommit dummy atoms for now
9688        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
9689 C now calculate distance from center of tube and direction vectors
9690       xmin=boxxsize
9691       ymin=boxysize
9692       zmin=boxzsize
9693
9694         do j=-1,1
9695          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
9696          vectube(1)=vectube(1)+boxxsize*j
9697          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
9698          vectube(2)=vectube(2)+boxysize*j
9699          vectube(3)=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
9700          vectube(3)=vectube(3)+boxzsize*j
9701
9702
9703          xminact=abs(vectube(1)-tubecenter(1))
9704          yminact=abs(vectube(2)-tubecenter(2))
9705          zminact=abs(vectube(3)-tubecenter(3))
9706
9707            if (xmin.gt.xminact) then
9708             xmin=xminact
9709             xtemp=vectube(1)
9710            endif
9711            if (ymin.gt.yminact) then
9712              ymin=yminact
9713              ytemp=vectube(2)
9714             endif
9715            if (zmin.gt.zminact) then
9716              zmin=zminact
9717              ztemp=vectube(3)
9718             endif
9719          enddo
9720       vectube(1)=xtemp
9721       vectube(2)=ytemp
9722       vectube(3)=ztemp
9723
9724       vectube(1)=vectube(1)-tubecenter(1)
9725       vectube(2)=vectube(2)-tubecenter(2)
9726       vectube(3)=vectube(3)-tubecenter(3)
9727
9728 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
9729 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
9730 C as the tube is infinity we do not calculate the Z-vector use of Z
9731 C as chosen axis
9732 C      vectube(3)=0.0d0
9733 C now calculte the distance
9734        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9735 C now normalize vector
9736       vectube(1)=vectube(1)/tub_r
9737       vectube(2)=vectube(2)/tub_r
9738       vectube(3)=vectube(3)/tub_r
9739 C calculte rdiffrence between r and r0
9740       rdiff=tub_r-tubeR0
9741 C and its 6 power
9742       rdiff6=rdiff**6.0d0
9743 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9744        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
9745 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
9746 C       print *,rdiff,rdiff6,pep_aa_tube
9747 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9748 C now we calculate gradient
9749        fac=(-12.0d0*pep_aa_tube/rdiff6-
9750      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
9751 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
9752 C     &rdiff,fac
9753          if (acavtubpep.eq.0.0d0) then
9754 C go to 667
9755          enecavtube(i)=0.0
9756          faccav=0.0
9757          else
9758          denominator=(1.0+dcavtubpep*rdiff6*rdiff6)
9759          enecavtube(i)=
9760      &   (bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)+ccavtubpep)
9761      &   /denominator
9762          enecavtube(i)=0.0
9763          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/sqrt(rdiff))
9764      &   *denominator-(bcavtubpep*rdiff+acavtubpep*sqrt(rdiff)
9765      &   +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)
9766      &   /denominator**2.0d0
9767 C         faccav=0.0
9768 C         fac=fac+faccav
9769 C 667     continue
9770          endif
9771 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtubpep,denominator,
9772 C     &   enecavtube(i),faccav
9773 C         print *,"licz=",
9774 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9775 CX         print *,"finene=",enetube(i+nres)+enecavtube(i)
9776
9777 C now direction of gg_tube vector
9778         do j=1,3
9779         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
9780         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
9781         enddo
9782         enddo
9783
9784        do i=itube_start,itube_end
9785         enecavtube(i)=0.0
9786 C Lets not jump over memory as we use many times iti
9787          iti=itype(i)
9788 C lets ommit dummy atoms for now
9789          if ((iti.eq.ntyp1)
9790 C in UNRES uncomment the line below as GLY has no side-chain...
9791 C      .or.(iti.eq.10)
9792      &   ) cycle
9793       xmin=boxxsize
9794       ymin=boxysize
9795       zmin=boxzsize
9796         do j=-1,1
9797          vectube(1)=mod((c(1,i+nres)),boxxsize)
9798          vectube(1)=vectube(1)+boxxsize*j
9799          vectube(2)=mod((c(2,i+nres)),boxysize)
9800          vectube(2)=vectube(2)+boxysize*j
9801          vectube(3)=mod((c(3,i+nres)),boxzsize)
9802          vectube(3)=vectube(3)+boxzsize*j
9803
9804
9805          xminact=abs(vectube(1)-tubecenter(1))
9806          yminact=abs(vectube(2)-tubecenter(2))
9807          zminact=abs(vectube(3)-tubecenter(3))
9808
9809            if (xmin.gt.xminact) then
9810             xmin=xminact
9811             xtemp=vectube(1)
9812            endif
9813            if (ymin.gt.yminact) then
9814              ymin=yminact
9815              ytemp=vectube(2)
9816             endif
9817            if (zmin.gt.zminact) then
9818              zmin=zminact
9819              ztemp=vectube(3)
9820             endif
9821          enddo
9822       vectube(1)=xtemp
9823       vectube(2)=ytemp
9824       vectube(3)=ztemp
9825
9826 C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
9827 C     &     tubecenter(2)
9828       vectube(1)=vectube(1)-tubecenter(1)
9829       vectube(2)=vectube(2)-tubecenter(2)
9830       vectube(3)=vectube(3)-tubecenter(3)
9831 C now calculte the distance
9832        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
9833 C now normalize vector
9834       vectube(1)=vectube(1)/tub_r
9835       vectube(2)=vectube(2)/tub_r
9836       vectube(3)=vectube(3)/tub_r
9837
9838 C calculte rdiffrence between r and r0
9839       rdiff=tub_r-tubeR0
9840 C and its 6 power
9841       rdiff6=rdiff**6.0d0
9842 C for vectorization reasons we will sumup at the end to avoid depenence of previous
9843        sc_aa_tube=sc_aa_tube_par(iti)
9844        sc_bb_tube=sc_bb_tube_par(iti)
9845        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
9846 C       enetube(i+nres)=0.0d0
9847 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
9848 C now we calculate gradient
9849        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
9850      &       6.0d0*sc_bb_tube/rdiff6/rdiff
9851 C       fac=0.0
9852 C now direction of gg_tube vector
9853 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
9854          if (acavtub(iti).eq.0.0d0) then
9855 C go to 667
9856          enecavtube(i+nres)=0.0
9857          faccav=0.0
9858          else
9859          denominator=(1.0+dcavtub(iti)*rdiff6*rdiff6)
9860          enecavtube(i+nres)=
9861      &   (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9862      &   /denominator
9863 C         enecavtube(i)=0.0
9864          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/sqrt(rdiff))
9865      &   *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)
9866      &   +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)
9867      &   /denominator**2.0d0
9868 C         faccav=0.0
9869          fac=fac+faccav
9870 C 667     continue
9871          endif
9872 C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
9873 C     &   enecavtube(i),faccav
9874 C         print *,"licz=",
9875 C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
9876 C         print *,"finene=",enetube(i+nres)+enecavtube(i)
9877          do j=1,3
9878           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
9879           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
9880          enddo
9881         enddo
9882 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
9883 C        do i=itube_start,itube_end
9884 C        enecav(i)=0.0
9885 C        iti=itype(i)
9886 C        if (acavtub(iti).eq.0.0) cycle
9887
9888
9889
9890         do i=itube_start,itube_end
9891           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i)
9892      & +enecavtube(i+nres)
9893         enddo
9894 C        print *,"ETUBE", etube
9895         return
9896         end
9897 C TO DO 1) add to total energy
9898 C       2) add to gradient summation
9899 C       3) add reading parameters (AND of course oppening of PARAM file)
9900 C       4) add reading the center of tube
9901 C       5) add COMMONs
9902 C       6) add to zerograd
9903