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