source/maxlik/src_MD_T_maxlik-NEWCORR.safe/energy_p_new_sc.F

   1       subroutine etotal(energia)
   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       include 'COMMON.FFIELD'
  16       include 'COMMON.DERIV'
  17       include 'COMMON.INTERACT'
  18       include 'COMMON.SBRIDGE'
  19       include 'COMMON.CHAIN'
  20       include 'COMMON.SHIELD'
  21       include 'COMMON.CONTROL'
  22       include 'COMMON.TORCNSTR'
  23       include 'COMMON.WEIGHTS'
  24       include 'COMMON.WEIGHTDER'
  25 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  26 c      call flush(iout)
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105,106) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw)
  34 cd    print '(a)','Exit ELJ'
  35       goto 107
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw)
  38       goto 107
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw)
  41       goto 107
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw)
  44       goto 107
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw)
  47       goto 107
  48 C New SC-SC potential
  49   106 call emomo(evdw,evdw_p,evdw_m)
  50 C
  51 C Calculate electrostatic (H-bonding) energy of the main chain.
  52 C
  53   107 continue
  54       call vec_and_deriv
  55       if (shield_mode.eq.1) then
  56        call set_shield_fac
  57       else if  (shield_mode.eq.2) then
  58        call set_shield_fac2
  59       endif
  60       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  61 C            write(iout,*) 'po eelec'
  62
  63 C Calculate excluded-volume interaction energy between peptide groups
  64 C and side chains.
  65 C
  66       call escp(evdw2,evdw2_14)
  67 c
  68 c Calculate the bond-stretching energy
  69 c
  70
  71       call ebond(estr)
  72 C       write (iout,*) "estr",estr
  73 C
  74 C Calculate the disulfide-bridge and other energy and the contributions
  75 C from other distance constraints.
  76 cd    print *,'Calling EHPB'
  77       call edis(ehpb)
  78 cd    print *,'EHPB exitted succesfully.'
  79 C
  80 C Calculate the virtual-bond-angle energy.
  81 C
  82 C      print *,'Bend energy finished.'
  83       if (wang.gt.0d0) then
  84        if (tor_mode.eq.0) then
  85          call ebend(ebe)
  86        else
  87 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  88 C energy function
  89          call ebend_kcc(ebe)
  90        endif
  91       else
  92         ebe=0.0d0
  93       endif
  94       ethetacnstr=0.0d0
  95       if (with_theta_constr) call etheta_constr(ethetacnstr)
  96 c      call ebend(ebe,ethetacnstr)
  97 cd    print *,'Bend energy finished.'
  98 C
  99 C Calculate the SC local energy.
 100 C
 101       call esc(escloc)
 102 C       print *,'SCLOC energy finished.'
 103 C
 104 C Calculate the virtual-bond torsional energy.
 105 C
 106       if (wtor.gt.0.0d0) then
 107          if (tor_mode.eq.0) then
 108            call etor(etors)
 109          else
 110 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 111 C energy function
 112            call etor_kcc(etors)
 113          endif
 114       else
 115         etors=0.0d0
 116       endif
 117       edihcnstr=0.0d0
 118       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 119 c      print *,"Processor",myrank," computed Utor"
 120 C
 121 C 6/23/01 Calculate double-torsional energy
 122 C
 123       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 124         call etor_d(etors_d)
 125       else
 126         etors_d=0
 127       endif
 128 c      print *,"Processor",myrank," computed Utord"
 129 C
 130       call eback_sc_corr(esccor)
 131
 132       if (wliptran.gt.0) then
 133         call Eliptransfer(eliptran)
 134       endif
 135
 136 C
 137 C 12/1/95 Multi-body terms
 138 C
 139       n_corr=0
 140       n_corr1=0
 141       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 142      &    .or. wturn6.gt.0.0d0) then
 143 c         write(iout,*)"calling multibody_eello"
 144          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 145 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 146 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 147       else
 148          ecorr=0.0d0
 149          ecorr5=0.0d0
 150          ecorr6=0.0d0
 151          eturn6=0.0d0
 152       endif
 153       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 154 c         write (iout,*) "Calling multibody_hbond"
 155          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 156       endif
 157 #ifdef SPLITELE
 158       if (shield_mode.gt.0) then
 159       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 160      & +welec*ees
 161      & +wvdwpp*evdw1
 162      & +wang*ebe+wtor*etors+wscloc*escloc
 163      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 164      & +wcorr6*ecorr6+wturn4*eello_turn4
 165      & +wturn3*eello_turn3+wturn6*eturn6
 166      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 167      & +wbond*estr+wsccor*esccor+ethetacnstr
 168      & +wliptran*eliptran
 169       else
 170       etot=wsc*(evdw+evdw_t)+wscp*evdw2+welec*ees
 171      & +wvdwpp*evdw1
 172      & +wang*ebe+wtor*etors+wscloc*escloc
 173      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 174      & +wcorr6*ecorr6+wturn4*eello_turn4
 175      & +wturn3*eello_turn3+wturn6*eturn6
 176      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 177      & +wbond*estr+wsccor*esccor+ethetacnstr
 178      & +wliptran*eliptran
 179       endif
 180 #else
 181       if (shield_mode.gt.0) then
 182       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 183      & +welec*(ees+evdw1)
 184      & +wang*ebe+wtor*etors+wscloc*escloc
 185      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 186      & +wcorr6*ecorr6+wturn4*eello_turn4
 187      & +wturn3*eello_turn3+wturn6*eturn6
 188      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 189      & +wbond*estr+wsccor*esccor+ethetacnstr
 190      & +wliptran*eliptran
 191       else
 192       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 193      & +welec*(ees+evdw1)
 194      & +wang*ebe+wtor*etors+wscloc*escloc
 195      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 196      & +wcorr6*ecorr6+wturn4*eello_turn4
 197      & +wturn3*eello_turn3+wturn6*eturn6
 198      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 199      & +wbond*estr+wsccor*esccor+ethetacnstr
 200      & +wliptran*eliptran
 201       endif
 202 #endif
 203       energia(0)=etot
 204       energia(1)=evdw
 205 #ifdef SCP14
 206       energia(2)=evdw2-evdw2_14
 207       energia(17)=evdw2_14
 208 #else
 209       energia(2)=evdw2
 210       energia(17)=0.0d0
 211 #endif
 212 #ifdef SPLITELE
 213       energia(3)=ees
 214       energia(16)=evdw1
 215 #else
 216       energia(3)=ees+evdw1
 217       energia(16)=0.0d0
 218 #endif
 219       energia(4)=ecorr
 220       energia(5)=ecorr5
 221       energia(6)=ecorr6
 222       energia(7)=eel_loc
 223       energia(8)=eello_turn3
 224       energia(9)=eello_turn4
 225       energia(10)=eturn6
 226       energia(11)=ebe
 227       energia(12)=escloc
 228       energia(13)=etors
 229       energia(14)=etors_d
 230       energia(15)=ehpb
 231       energia(18)=estr
 232       energia(19)=esccor
 233       energia(20)=edihcnstr
 234       energia(21)=evdw_t
 235       energia(24)=ethetacnstr
 236       energia(22)=eliptran
 237 c detecting NaNQ
 238 #ifdef ISNAN
 239 #ifdef AIX
 240       if (isnan(etot).ne.0) energia(0)=1.0d+99
 241 #else
 242       if (isnan(etot)) energia(0)=1.0d+99
 243 #endif
 244 #else
 245       i=0
 246 #ifdef WINPGI
 247       idumm=proc_proc(etot,i)
 248 #else
 249       call proc_proc(etot,i)
 250 #endif
 251       if(i.eq.1)energia(0)=1.0d+99
 252 #endif
 253 #ifdef MPL
 254 c     endif
 255 #endif
 256 #ifdef DEBUG
 257       call enerprint(energia)
 258 #endif
 259       if (calc_grad) then
 260 C
 261 C Sum up the components of the Cartesian gradient.
 262 C
 263 #ifdef SPLITELE
 264       do i=1,nct
 265         do j=1,3
 266       if (shield_mode.eq.0) then
 267           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 268      &                welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 269      &                wbond*gradb(j,i)+
 270      &                wstrain*ghpbc(j,i)+
 271      &                wcorr*gradcorr(j,i)+
 272      &                wel_loc*gel_loc(j,i)+
 273      &                wturn3*gcorr3_turn(j,i)+
 274      &                wturn4*gcorr4_turn(j,i)+
 275      &                wcorr5*gradcorr5(j,i)+
 276      &                wcorr6*gradcorr6(j,i)+
 277      &                wturn6*gcorr6_turn(j,i)+
 278      &                wsccor*gsccorc(j,i)
 279      &               +wliptran*gliptranc(j,i)
 280           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 281      &                  wbond*gradbx(j,i)+
 282      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 283      &                  wsccor*gsccorx(j,i)
 284      &                 +wliptran*gliptranx(j,i)
 285         else
 286           gradc(j,i,icg)=wsc*gvdwc(j,i)
 287      &                +wscp*gvdwc_scp(j,i)+
 288      &               welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 289      &                wbond*gradb(j,i)+
 290      &                wstrain*ghpbc(j,i)+
 291      &                wcorr*gradcorr(j,i)+
 292      &                wel_loc*gel_loc(j,i)+
 293      &                wturn3*gcorr3_turn(j,i)+
 294      &                wturn4*gcorr4_turn(j,i)+
 295      &                wcorr5*gradcorr5(j,i)+
 296      &                wcorr6*gradcorr6(j,i)+
 297      &                wturn6*gcorr6_turn(j,i)+
 298      &                wsccor*gsccorc(j,i)
 299      &               +wliptran*gliptranc(j,i)
 300      &                 +welec*gshieldc(j,i)
 301      &                 +welec*gshieldc_loc(j,i)
 302      &                 +wcorr*gshieldc_ec(j,i)
 303      &                 +wcorr*gshieldc_loc_ec(j,i)
 304      &                 +wturn3*gshieldc_t3(j,i)
 305      &                 +wturn3*gshieldc_loc_t3(j,i)
 306      &                 +wturn4*gshieldc_t4(j,i)
 307      &                 +wturn4*gshieldc_loc_t4(j,i)
 308      &                 +wel_loc*gshieldc_ll(j,i)
 309      &                 +wel_loc*gshieldc_loc_ll(j,i)
 310
 311           gradx(j,i,icg)=wsc*gvdwx(j,i)
 312      &                 +wscp*gradx_scp(j,i)+
 313      &                  wbond*gradbx(j,i)+
 314      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 315      &                  wsccor*gsccorx(j,i)
 316      &                 +wliptran*gliptranx(j,i)
 317      &                 +welec*gshieldx(j,i)
 318      &                 +wcorr*gshieldx_ec(j,i)
 319      &                 +wturn3*gshieldx_t3(j,i)
 320      &                 +wturn4*gshieldx_t4(j,i)
 321      &                 +wel_loc*gshieldx_ll(j,i)
 322
 323
 324         endif
 325         enddo
 326 #else
 327       do i=1,nct
 328         do j=1,3
 329                 if (shield_mode.eq.0) then
 330           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 331      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 332      &                wbond*gradb(j,i)+
 333      &                wcorr*gradcorr(j,i)+
 334      &                wel_loc*gel_loc(j,i)+
 335      &                wturn3*gcorr3_turn(j,i)+
 336      &                wturn4*gcorr4_turn(j,i)+
 337      &                wcorr5*gradcorr5(j,i)+
 338      &                wcorr6*gradcorr6(j,i)+
 339      &                wturn6*gcorr6_turn(j,i)+
 340      &                wsccor*gsccorc(j,i)
 341      &               +wliptran*gliptranc(j,i)
 342           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 343      &                  wbond*gradbx(j,i)+
 344      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 345      &                  wsccor*gsccorx(j,i)
 346      &                 +wliptran*gliptranx(j,i)
 347               else
 348           gradc(j,i,icg)=wsc*gvdwc(j,i)+
 349      &                   wscp*gvdwc_scp(j,i)+
 350      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 351      &                wbond*gradb(j,i)+
 352      &                wcorr*gradcorr(j,i)+
 353      &                wel_loc*gel_loc(j,i)+
 354      &                wturn3*gcorr3_turn(j,i)+
 355      &                wturn4*gcorr4_turn(j,i)+
 356      &                wcorr5*gradcorr5(j,i)+
 357      &                wcorr6*gradcorr6(j,i)+
 358      &                wturn6*gcorr6_turn(j,i)+
 359      &                wsccor*gsccorc(j,i)
 360      &               +wliptran*gliptranc(j,i)
 361      &                 +welec*gshieldc(j,i)
 362      &                 +welec*gshieldc_loc(j,i)
 363      &                 +wcorr*gshieldc_ec(j,i)
 364      &                 +wcorr*gshieldc_loc_ec(j,i)
 365      &                 +wturn3*gshieldc_t3(j,i)
 366      &                 +wturn3*gshieldc_loc_t3(j,i)
 367      &                 +wturn4*gshieldc_t4(j,i)
 368      &                 +wturn4*gshieldc_loc_t4(j,i)
 369      &                 +wel_loc*gshieldc_ll(j,i)
 370      &                 +wel_loc*gshieldc_loc_ll(j,i)
 371
 372           gradx(j,i,icg)=wsc*gvdwx(j,i)+
 373      &                  wscp*gradx_scp(j,i)+
 374      &                  wbond*gradbx(j,i)+
 375      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 376      &                  wsccor*gsccorx(j,i)
 377      &                 +wliptran*gliptranx(j,i)
 378      &                 +welec*gshieldx(j,i)
 379      &                 +wcorr*gshieldx_ec(j,i)
 380      &                 +wturn3*gshieldx_t3(j,i)
 381      &                 +wturn4*gshieldx_t4(j,i)
 382      &                 +wel_loc*gshieldx_ll(j,i)
 383
 384          endif
 385         enddo
 386 #endif
 387       enddo
 388
 389
 390       do i=1,nres-3
 391         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 392      &   +wcorr5*g_corr5_loc(i)
 393      &   +wcorr6*g_corr6_loc(i)
 394      &   +wturn4*gel_loc_turn4(i)
 395      &   +wturn3*gel_loc_turn3(i)
 396      &   +wturn6*gel_loc_turn6(i)
 397      &   +wel_loc*gel_loc_loc(i)
 398 c     &   +wsccor*gsccor_loc(i)
 399 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 400       enddo
 401       endif
 402 c      if (dyn_ss) call dyn_set_nss
 403       return
 404       end
 405 C------------------------------------------------------------------------
 406       subroutine enerprint(energia)
 407       implicit real*8 (a-h,o-z)
 408       include 'DIMENSIONS'
 409       include 'DIMENSIONS.ZSCOPT'
 410       include 'COMMON.IOUNITS'
 411       include 'COMMON.FFIELD'
 412       include 'COMMON.SBRIDGE'
 413       double precision energia(0:max_ene)
 414       etot=energia(0)
 415       evdw=energia(1)+energia(21)
 416 #ifdef SCP14
 417       evdw2=energia(2)+energia(17)
 418 #else
 419       evdw2=energia(2)
 420 #endif
 421       ees=energia(3)
 422 #ifdef SPLITELE
 423       evdw1=energia(16)
 424 #endif
 425       ecorr=energia(4)
 426       ecorr5=energia(5)
 427       ecorr6=energia(6)
 428       eel_loc=energia(7)
 429       eello_turn3=energia(8)
 430       eello_turn4=energia(9)
 431       eello_turn6=energia(10)
 432       ebe=energia(11)
 433       escloc=energia(12)
 434       etors=energia(13)
 435       etors_d=energia(14)
 436       ehpb=energia(15)
 437       esccor=energia(19)
 438       edihcnstr=energia(20)
 439       estr=energia(18)
 440       ethetacnstr=energia(24)
 441       eliptran=energia(22)
 442 #ifdef SPLITELE
 443       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,
 444      &  wvdwpp,
 445      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor,
 446      &  etors_d,wtor_d,ehpb,wstrain,
 447      &  ecorr,wcorr,ecorr5,wcorr5,ecorr6,wcorr6,
 448      &  eel_loc,wel_loc,eello_turn3,wturn3,
 449      &  eello_turn4,wturn4,eello_turn6,wturn6,
 450      &  esccor,wsccor,edihcnstr,ethetacnstr,ebr*nss,
 451      & eliptran,wliptran,etot
 452    10 format (/'Virtual-chain energies:'//
 453      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 454      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 455      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 456      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 457      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 458      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 459      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 460      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 461      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 462      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 463      & ' (SS bridges & dist. cnstr.)'/
 464      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 465      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 466      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 467      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 468      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 469      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 470      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 471      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 472      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 473      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 474      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 475      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 476      & 'ETOT=  ',1pE16.6,' (total)')
 477 #else
 478       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,estr,wbond,
 479      &  ebe,wang,escloc,wscloc,etors,wtor,etors_d,wtor_d,
 480      &  ehpb,wstrain,ecorr,wcorr,ecorr5,wcorr5,
 481      &  ecorr6,wcorr6,eel_loc,wel_loc,
 482      &  eello_turn3,wturn3,eello_turn4,wturn4,
 483      &  eello_turn6,wturn6,esccor,wsccor,
 484      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,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)'/
 489      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 490      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 491      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 492      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 493      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 494      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 495      & ' (SS bridges & dist. cnstr.)'/
 496      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 497      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 498      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 499      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 500      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 501      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 502      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 503      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 504      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 505      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 506      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 507      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 508      & 'ETOT=  ',1pE16.6,' (total)')
 509 #endif
 510       return
 511       end
 512 C-----------------------------------------------------------------------
 513       subroutine elj(evdw)
 514 C
 515 C This subroutine calculates the interaction energy of nonbonded side chains
 516 C assuming the LJ potential of interaction.
 517 C
 518       implicit real*8 (a-h,o-z)
 519       include 'DIMENSIONS'
 520       include 'DIMENSIONS.ZSCOPT'
 521       parameter (accur=1.0d-10)
 522       include 'COMMON.GEO'
 523       include 'COMMON.VAR'
 524       include 'COMMON.LOCAL'
 525       include 'COMMON.CHAIN'
 526       include 'COMMON.DERIV'
 527       include 'COMMON.INTERACT'
 528       include 'COMMON.TORSION'
 529       include 'COMMON.WEIGHTDER'
 530       include 'COMMON.SBRIDGE'
 531       include 'COMMON.NAMES'
 532       include 'COMMON.IOUNITS'
 533       include 'COMMON.CONTACTS'
 534       dimension gg(3)
 535       integer icant
 536       external icant
 537 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 538       do i=1,nntyp
 539         do j=1,2
 540           eneps_temp(j,i)=0.0d0
 541         enddo
 542       enddo
 543       evdw=0.0D0
 544       do i=iatsc_s,iatsc_e
 545         itypi=itype(i)
 546         itypi1=itype(i+1)
 547         xi=c(1,nres+i)
 548         yi=c(2,nres+i)
 549         zi=c(3,nres+i)
 550 C Change 12/1/95
 551         num_conti=0
 552 C
 553 C Calculate SC interaction energy.
 554 C
 555         do iint=1,nint_gr(i)
 556 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 557 cd   &                  'iend=',iend(i,iint)
 558           do j=istart(i,iint),iend(i,iint)
 559             itypj=itype(j)
 560             xj=c(1,nres+j)-xi
 561             yj=c(2,nres+j)-yi
 562             zj=c(3,nres+j)-zi
 563 C Change 12/1/95 to calculate four-body interactions
 564             rij=xj*xj+yj*yj+zj*zj
 565             rrij=1.0D0/rij
 566 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 567             eps0ij=eps(itypi,itypj)
 568             fac=rrij**expon2
 569             e1=fac*fac*aa(itypi,itypj)
 570             e2=fac*bb(itypi,itypj)
 571             evdwij=e1+e2
 572             ij=icant(itypi,itypj)
 573             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 574             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 575 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 576 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 577 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 578 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 579 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 580 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 581             evdw=evdw+evdwij
 582             if (calc_grad) then
 583 C
 584 C Calculate the components of the gradient in DC and X
 585 C
 586             fac=-rrij*(e1+evdwij)
 587             gg(1)=xj*fac
 588             gg(2)=yj*fac
 589             gg(3)=zj*fac
 590             do k=1,3
 591               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 592               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 593             enddo
 594             do k=i,j-1
 595               do l=1,3
 596                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 597               enddo
 598             enddo
 599             endif
 600 C
 601 C 12/1/95, revised on 5/20/97
 602 C
 603 C Calculate the contact function. The ith column of the array JCONT will
 604 C contain the numbers of atoms that make contacts with the atom I (of numbers
 605 C greater than I). The arrays FACONT and GACONT will contain the values of
 606 C the contact function and its derivative.
 607 C
 608 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 609 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 610 C Uncomment next line, if the correlation interactions are contact function only
 611             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 612               rij=dsqrt(rij)
 613               sigij=sigma(itypi,itypj)
 614               r0ij=rs0(itypi,itypj)
 615 C
 616 C Check whether the SC's are not too far to make a contact.
 617 C
 618               rcut=1.5d0*r0ij
 619               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 620 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 621 C
 622               if (fcont.gt.0.0D0) then
 623 C If the SC-SC distance if close to sigma, apply spline.
 624 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 625 cAdam &             fcont1,fprimcont1)
 626 cAdam           fcont1=1.0d0-fcont1
 627 cAdam           if (fcont1.gt.0.0d0) then
 628 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 629 cAdam             fcont=fcont*fcont1
 630 cAdam           endif
 631 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 632 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 633 cga             do k=1,3
 634 cga               gg(k)=gg(k)*eps0ij
 635 cga             enddo
 636 cga             eps0ij=-evdwij*eps0ij
 637 C Uncomment for AL's type of SC correlation interactions.
 638 cadam           eps0ij=-evdwij
 639                 num_conti=num_conti+1
 640                 jcont(num_conti,i)=j
 641                 facont(num_conti,i)=fcont*eps0ij
 642                 fprimcont=eps0ij*fprimcont/rij
 643                 fcont=expon*fcont
 644 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 645 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 646 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 647 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 648                 gacont(1,num_conti,i)=-fprimcont*xj
 649                 gacont(2,num_conti,i)=-fprimcont*yj
 650                 gacont(3,num_conti,i)=-fprimcont*zj
 651 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 652 cd              write (iout,'(2i3,3f10.5)')
 653 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 654               endif
 655             endif
 656           enddo      ! j
 657         enddo        ! iint
 658 C Change 12/1/95
 659         num_cont(i)=num_conti
 660       enddo          ! i
 661       if (calc_grad) then
 662       do i=1,nct
 663         do j=1,3
 664           gvdwc(j,i)=expon*gvdwc(j,i)
 665           gvdwx(j,i)=expon*gvdwx(j,i)
 666         enddo
 667       enddo
 668       endif
 669 C******************************************************************************
 670 C
 671 C                              N O T E !!!
 672 C
 673 C To save time, the factor of EXPON has been extracted from ALL components
 674 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 675 C use!
 676 C
 677 C******************************************************************************
 678       return
 679       end
 680 C-----------------------------------------------------------------------------
 681       subroutine eljk(evdw)
 682 C
 683 C This subroutine calculates the interaction energy of nonbonded side chains
 684 C assuming the LJK potential of interaction.
 685 C
 686       implicit real*8 (a-h,o-z)
 687       include 'DIMENSIONS'
 688       include 'DIMENSIONS.ZSCOPT'
 689       include 'COMMON.GEO'
 690       include 'COMMON.VAR'
 691       include 'COMMON.LOCAL'
 692       include 'COMMON.CHAIN'
 693       include 'COMMON.DERIV'
 694       include 'COMMON.INTERACT'
 695       include 'COMMON.WEIGHTDER'
 696       include 'COMMON.IOUNITS'
 697       include 'COMMON.NAMES'
 698       dimension gg(3)
 699       logical scheck
 700       integer icant
 701       external icant
 702 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 703       do i=1,nntyp
 704         do j=1,2
 705           eneps_temp(j,i)=0.0d0
 706         enddo
 707       enddo
 708       evdw=0.0D0
 709       do i=iatsc_s,iatsc_e
 710         itypi=itype(i)
 711         itypi1=itype(i+1)
 712         xi=c(1,nres+i)
 713         yi=c(2,nres+i)
 714         zi=c(3,nres+i)
 715 C
 716 C Calculate SC interaction energy.
 717 C
 718         do iint=1,nint_gr(i)
 719           do j=istart(i,iint),iend(i,iint)
 720             itypj=itype(j)
 721             xj=c(1,nres+j)-xi
 722             yj=c(2,nres+j)-yi
 723             zj=c(3,nres+j)-zi
 724             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 725             fac_augm=rrij**expon
 726             e_augm=augm(itypi,itypj)*fac_augm
 727             r_inv_ij=dsqrt(rrij)
 728             rij=1.0D0/r_inv_ij
 729             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 730             fac=r_shift_inv**expon
 731             e1=fac*fac*aa(itypi,itypj)
 732             e2=fac*bb(itypi,itypj)
 733             evdwij=e_augm+e1+e2
 734             ij=icant(itypi,itypj)
 735             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 736      &        /dabs(eps(itypi,itypj))
 737             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 738 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 739 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 740 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 741 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 742 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 743 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 744 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 745             evdw=evdw+evdwij
 746             if (calc_grad) then
 747 C
 748 C Calculate the components of the gradient in DC and X
 749 C
 750             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 751             gg(1)=xj*fac
 752             gg(2)=yj*fac
 753             gg(3)=zj*fac
 754             do k=1,3
 755               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 756               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 757             enddo
 758             do k=i,j-1
 759               do l=1,3
 760                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 761               enddo
 762             enddo
 763             endif
 764           enddo      ! j
 765         enddo        ! iint
 766       enddo          ! i
 767       if (calc_grad) then
 768       do i=1,nct
 769         do j=1,3
 770           gvdwc(j,i)=expon*gvdwc(j,i)
 771           gvdwx(j,i)=expon*gvdwx(j,i)
 772         enddo
 773       enddo
 774       endif
 775       return
 776       end
 777 C-----------------------------------------------------------------------------
 778       subroutine ebp(evdw)
 779 C
 780 C This subroutine calculates the interaction energy of nonbonded side chains
 781 C assuming the Berne-Pechukas potential of interaction.
 782 C
 783       implicit real*8 (a-h,o-z)
 784       include 'DIMENSIONS'
 785       include 'DIMENSIONS.ZSCOPT'
 786       include 'COMMON.GEO'
 787       include 'COMMON.VAR'
 788       include 'COMMON.LOCAL'
 789       include 'COMMON.CHAIN'
 790       include 'COMMON.DERIV'
 791       include 'COMMON.NAMES'
 792       include 'COMMON.INTERACT'
 793       include 'COMMON.WEIGHTDER'
 794       include 'COMMON.IOUNITS'
 795       include 'COMMON.CALC'
 796       common /srutu/ icall
 797 c     double precision rrsave(maxdim)
 798       logical lprn
 799       integer icant
 800       external icant
 801       do i=1,nntyp
 802         do j=1,2
 803           eneps_temp(j,i)=0.0d0
 804         enddo
 805       enddo
 806       evdw=0.0D0
 807 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 808       evdw=0.0D0
 809 c     if (icall.eq.0) then
 810 c       lprn=.true.
 811 c     else
 812         lprn=.false.
 813 c     endif
 814       ind=0
 815       do i=iatsc_s,iatsc_e
 816         itypi=itype(i)
 817         itypi1=itype(i+1)
 818         xi=c(1,nres+i)
 819         yi=c(2,nres+i)
 820         zi=c(3,nres+i)
 821         dxi=dc_norm(1,nres+i)
 822         dyi=dc_norm(2,nres+i)
 823         dzi=dc_norm(3,nres+i)
 824         dsci_inv=vbld_inv(i+nres)
 825 C
 826 C Calculate SC interaction energy.
 827 C
 828         do iint=1,nint_gr(i)
 829           do j=istart(i,iint),iend(i,iint)
 830             ind=ind+1
 831             itypj=itype(j)
 832             dscj_inv=vbld_inv(j+nres)
 833             chi1=chi(itypi,itypj)
 834             chi2=chi(itypj,itypi)
 835             chi12=chi1*chi2
 836             chip1=chip(itypi)
 837             chip2=chip(itypj)
 838             chip12=chip1*chip2
 839             alf1=alp(itypi)
 840             alf2=alp(itypj)
 841             alf12=0.5D0*(alf1+alf2)
 842 C For diagnostics only!!!
 843 c           chi1=0.0D0
 844 c           chi2=0.0D0
 845 c           chi12=0.0D0
 846 c           chip1=0.0D0
 847 c           chip2=0.0D0
 848 c           chip12=0.0D0
 849 c           alf1=0.0D0
 850 c           alf2=0.0D0
 851 c           alf12=0.0D0
 852             xj=c(1,nres+j)-xi
 853             yj=c(2,nres+j)-yi
 854             zj=c(3,nres+j)-zi
 855             dxj=dc_norm(1,nres+j)
 856             dyj=dc_norm(2,nres+j)
 857             dzj=dc_norm(3,nres+j)
 858             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 859 cd          if (icall.eq.0) then
 860 cd            rrsave(ind)=rrij
 861 cd          else
 862 cd            rrij=rrsave(ind)
 863 cd          endif
 864             rij=dsqrt(rrij)
 865 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 866             call sc_angular
 867 C Calculate whole angle-dependent part of epsilon and contributions
 868 C to its derivatives
 869             fac=(rrij*sigsq)**expon2
 870             e1=fac*fac*aa(itypi,itypj)
 871             e2=fac*bb(itypi,itypj)
 872             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 873             eps2der=evdwij*eps3rt
 874             eps3der=evdwij*eps2rt
 875             evdwij=evdwij*eps2rt*eps3rt
 876             ij=icant(itypi,itypj)
 877             aux=eps1*eps2rt**2*eps3rt**2
 878             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 879      &        /dabs(eps(itypi,itypj))
 880             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 881             evdw=evdw+evdwij
 882             if (calc_grad) then
 883             if (lprn) then
 884             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 885             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 886 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 887 cd     &        restyp(itypi),i,restyp(itypj),j,
 888 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 889 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 890 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 891 cd     &        evdwij
 892             endif
 893 C Calculate gradient components.
 894             e1=e1*eps1*eps2rt**2*eps3rt**2
 895             fac=-expon*(e1+evdwij)
 896             sigder=fac/sigsq
 897             fac=rrij*fac
 898 C Calculate radial part of the gradient
 899             gg(1)=xj*fac
 900             gg(2)=yj*fac
 901             gg(3)=zj*fac
 902 C Calculate the angular part of the gradient and sum add the contributions
 903 C to the appropriate components of the Cartesian gradient.
 904             call sc_grad
 905             endif
 906           enddo      ! j
 907         enddo        ! iint
 908       enddo          ! i
 909 c     stop
 910       return
 911       end
 912 C-----------------------------------------------------------------------------
 913       subroutine egb(evdw)
 914 C
 915 C This subroutine calculates the interaction energy of nonbonded side chains
 916 C assuming the Gay-Berne potential of interaction.
 917 C
 918       implicit real*8 (a-h,o-z)
 919       include 'DIMENSIONS'
 920       include 'DIMENSIONS.ZSCOPT'
 921       include 'COMMON.GEO'
 922       include 'COMMON.VAR'
 923       include 'COMMON.LOCAL'
 924       include 'COMMON.CHAIN'
 925       include 'COMMON.DERIV'
 926       include 'COMMON.NAMES'
 927       include 'COMMON.INTERACT'
 928       include 'COMMON.WEIGHTDER'
 929       include 'COMMON.IOUNITS'
 930       include 'COMMON.CALC'
 931       logical lprn
 932       common /srutu/icall
 933       integer icant
 934       external icant
 935       do i=1,nntyp
 936         do j=1,2
 937           eneps_temp(j,i)=0.0d0
 938         enddo
 939       enddo
 940       evdw=0.0D0
 941 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 942       evdw=0.0D0
 943       lprn=.false.
 944 c      if (icall.gt.0) lprn=.true.
 945       ind=0
 946       do i=iatsc_s,iatsc_e
 947         itypi=itype(i)
 948         itypi1=itype(i+1)
 949         xi=c(1,nres+i)
 950         yi=c(2,nres+i)
 951         zi=c(3,nres+i)
 952         dxi=dc_norm(1,nres+i)
 953         dyi=dc_norm(2,nres+i)
 954         dzi=dc_norm(3,nres+i)
 955         dsci_inv=vbld_inv(i+nres)
 956 C
 957 C Calculate SC interaction energy.
 958 C
 959         do iint=1,nint_gr(i)
 960           do j=istart(i,iint),iend(i,iint)
 961             ind=ind+1
 962             itypj=itype(j)
 963             dscj_inv=vbld_inv(j+nres)
 964             sig0ij=sigma(itypi,itypj)
 965             chi1=chi(itypi,itypj)
 966             chi2=chi(itypj,itypi)
 967             chi12=chi1*chi2
 968             chip1=chip(itypi)
 969             chip2=chip(itypj)
 970             chip12=chip1*chip2
 971             alf1=alp(itypi)
 972             alf2=alp(itypj)
 973             alf12=0.5D0*(alf1+alf2)
 974 C For diagnostics only!!!
 975 c           chi1=0.0D0
 976 c           chi2=0.0D0
 977 c           chi12=0.0D0
 978 c           chip1=0.0D0
 979 c           chip2=0.0D0
 980 c           chip12=0.0D0
 981 c           alf1=0.0D0
 982 c           alf2=0.0D0
 983 c           alf12=0.0D0
 984             xj=c(1,nres+j)-xi
 985             yj=c(2,nres+j)-yi
 986             zj=c(3,nres+j)-zi
 987             dxj=dc_norm(1,nres+j)
 988             dyj=dc_norm(2,nres+j)
 989             dzj=dc_norm(3,nres+j)
 990 c            write (iout,*) i,j,xj,yj,zj
 991             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 992             rij=dsqrt(rrij)
 993 C Calculate angle-dependent terms of energy and contributions to their
 994 C derivatives.
 995             call sc_angular
 996             sigsq=1.0D0/sigsq
 997             sig=sig0ij*dsqrt(sigsq)
 998             rij_shift=1.0D0/rij-sig+sig0ij
 999 C I hate to put IF's in the loops, but here don't have another choice!!!!
1000             if (rij_shift.le.0.0D0) then
1001               evdw=1.0D20
1002               return
1003             endif
1004             sigder=-sig*sigsq
1005 c---------------------------------------------------------------
1006             rij_shift=1.0D0/rij_shift
1007             fac=rij_shift**expon
1008             e1=fac*fac*aa(itypi,itypj)
1009             e2=fac*bb(itypi,itypj)
1010             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1011             eps2der=evdwij*eps3rt
1012             eps3der=evdwij*eps2rt
1013             evdwij=evdwij*eps2rt*eps3rt
1014             evdw=evdw+evdwij
1015             ij=icant(itypi,itypj)
1016             aux=eps1*eps2rt**2*eps3rt**2
1017 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1018 c     &        /dabs(eps(itypi,itypj))
1019 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1020 c-----------------------
1021             eps0ij=eps(itypi,itypj)
1022             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1/ftune_eps(eps0ij)
1023             rr0ij=r0(itypi,itypj)
1024             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps0ij
1025 c            eneps_temp(2,ij)=eneps_temp(2,ij)+(rij_shift*rr0ij)**expon
1026 c-----------------------
1027 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1028 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1029 c     &         aux*e2/eps(itypi,itypj)
1030             if (lprn) then
1031             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1032             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1033             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1034      &        restyp(itypi),i,restyp(itypj),j,
1035      &        epsi,sigm,chi1,chi2,chip1,chip2,
1036      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1037      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1038      &        evdwij
1039             endif
1040             if (calc_grad) then
1041 C Calculate gradient components.
1042             e1=e1*eps1*eps2rt**2*eps3rt**2
1043             fac=-expon*(e1+evdwij)*rij_shift
1044             sigder=fac*sigder
1045             fac=rij*fac
1046 C Calculate the radial part of the gradient
1047             gg(1)=xj*fac
1048             gg(2)=yj*fac
1049             gg(3)=zj*fac
1050 C Calculate angular part of the gradient.
1051             call sc_grad
1052             endif
1053           enddo      ! j
1054         enddo        ! iint
1055       enddo          ! i
1056       return
1057       end
1058 C-----------------------------------------------------------------------------
1059       subroutine egbv(evdw)
1060 C
1061 C This subroutine calculates the interaction energy of nonbonded side chains
1062 C assuming the Gay-Berne-Vorobjev potential of interaction.
1063 C
1064       implicit real*8 (a-h,o-z)
1065       include 'DIMENSIONS'
1066       include 'DIMENSIONS.ZSCOPT'
1067       include 'COMMON.GEO'
1068       include 'COMMON.VAR'
1069       include 'COMMON.LOCAL'
1070       include 'COMMON.CHAIN'
1071       include 'COMMON.DERIV'
1072       include 'COMMON.NAMES'
1073       include 'COMMON.INTERACT'
1074       include 'COMMON.WEIGHTDER'
1075       include 'COMMON.IOUNITS'
1076       include 'COMMON.CALC'
1077       common /srutu/ icall
1078       logical lprn
1079       integer icant
1080       external icant
1081       do i=1,nntyp
1082         do j=1,2
1083           eneps_temp(j,i)=0.0d0
1084         enddo
1085       enddo
1086       evdw=0.0D0
1087 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1088       evdw=0.0D0
1089       lprn=.false.
1090 c      if (icall.gt.0) lprn=.true.
1091       ind=0
1092       do i=iatsc_s,iatsc_e
1093         itypi=itype(i)
1094         itypi1=itype(i+1)
1095         xi=c(1,nres+i)
1096         yi=c(2,nres+i)
1097         zi=c(3,nres+i)
1098         dxi=dc_norm(1,nres+i)
1099         dyi=dc_norm(2,nres+i)
1100         dzi=dc_norm(3,nres+i)
1101         dsci_inv=vbld_inv(i+nres)
1102 C
1103 C Calculate SC interaction energy.
1104 C
1105         do iint=1,nint_gr(i)
1106           do j=istart(i,iint),iend(i,iint)
1107             ind=ind+1
1108             itypj=itype(j)
1109             dscj_inv=vbld_inv(j+nres)
1110             sig0ij=sigma(itypi,itypj)
1111             r0ij=r0(itypi,itypj)
1112             chi1=chi(itypi,itypj)
1113             chi2=chi(itypj,itypi)
1114             chi12=chi1*chi2
1115             chip1=chip(itypi)
1116             chip2=chip(itypj)
1117             chip12=chip1*chip2
1118             alf1=alp(itypi)
1119             alf2=alp(itypj)
1120             alf12=0.5D0*(alf1+alf2)
1121 C For diagnostics only!!!
1122 c           chi1=0.0D0
1123 c           chi2=0.0D0
1124 c           chi12=0.0D0
1125 c           chip1=0.0D0
1126 c           chip2=0.0D0
1127 c           chip12=0.0D0
1128 c           alf1=0.0D0
1129 c           alf2=0.0D0
1130 c           alf12=0.0D0
1131             xj=c(1,nres+j)-xi
1132             yj=c(2,nres+j)-yi
1133             zj=c(3,nres+j)-zi
1134             dxj=dc_norm(1,nres+j)
1135             dyj=dc_norm(2,nres+j)
1136             dzj=dc_norm(3,nres+j)
1137             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1138             rij=dsqrt(rrij)
1139 C Calculate angle-dependent terms of energy and contributions to their
1140 C derivatives.
1141             call sc_angular
1142             sigsq=1.0D0/sigsq
1143             sig=sig0ij*dsqrt(sigsq)
1144             rij_shift=1.0D0/rij-sig+r0ij
1145 C I hate to put IF's in the loops, but here don't have another choice!!!!
1146             if (rij_shift.le.0.0D0) then
1147               evdw=1.0D20
1148               return
1149             endif
1150             sigder=-sig*sigsq
1151 c---------------------------------------------------------------
1152             rij_shift=1.0D0/rij_shift
1153             fac=rij_shift**expon
1154             e1=fac*fac*aa(itypi,itypj)
1155             e2=fac*bb(itypi,itypj)
1156             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1157             eps2der=evdwij*eps3rt
1158             eps3der=evdwij*eps2rt
1159             fac_augm=rrij**expon
1160             e_augm=augm(itypi,itypj)*fac_augm
1161             evdwij=evdwij*eps2rt*eps3rt
1162             evdw=evdw+evdwij+e_augm
1163             ij=icant(itypi,itypj)
1164             aux=eps1*eps2rt**2*eps3rt**2
1165             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1166      &        /dabs(eps(itypi,itypj))
1167             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1168 c            eneps_temp(ij)=eneps_temp(ij)
1169 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1170 c            if (lprn) then
1171 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1172 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1173 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1174 c     &        restyp(itypi),i,restyp(itypj),j,
1175 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1176 c     &        chi1,chi2,chip1,chip2,
1177 c     &        eps1,eps2rt**2,eps3rt**2,
1178 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1179 c     &        evdwij+e_augm
1180 c            endif
1181             if (calc_grad) then
1182 C Calculate gradient components.
1183             e1=e1*eps1*eps2rt**2*eps3rt**2
1184             fac=-expon*(e1+evdwij)*rij_shift
1185             sigder=fac*sigder
1186             fac=rij*fac-2*expon*rrij*e_augm
1187 C Calculate the radial part of the gradient
1188             gg(1)=xj*fac
1189             gg(2)=yj*fac
1190             gg(3)=zj*fac
1191 C Calculate angular part of the gradient.
1192             call sc_grad
1193             endif
1194           enddo      ! j
1195         enddo        ! iint
1196       enddo          ! i
1197       return
1198       end
1199 C-----------------------------------------------------------------------------
1200       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1201 C
1202 C This subroutine calculates the interaction energy of nonbonded side chains
1203 C assuming the Gay-Berne potential of interaction.
1204 C
1205        IMPLICIT NONE
1206        INCLUDE 'DIMENSIONS'
1207        INCLUDE 'DIMENSIONS.ZSCOPT'
1208        INCLUDE 'COMMON.CALC'
1209        INCLUDE 'COMMON.CONTROL'
1210        INCLUDE 'COMMON.CHAIN'
1211        INCLUDE 'COMMON.DERIV'
1212        INCLUDE 'COMMON.EMP'
1213        INCLUDE 'COMMON.GEO'
1214        INCLUDE 'COMMON.INTERACT'
1215        INCLUDE 'COMMON.IOUNITS'
1216        INCLUDE 'COMMON.LOCAL'
1217        INCLUDE 'COMMON.NAMES'
1218        INCLUDE 'COMMON.VAR'
1219        INCLUDE 'COMMON.WEIGHTDER'
1220        logical lprn
1221        double precision scalar
1222        double precision ener(4)
1223        integer troll
1224        integer iint,ij
1225        integer icant
1226
1227        energy_dec=.false.
1228        IF (energy_dec) write (iout,'(a)')
1229      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1230      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1231        evdw   = 0.0D0
1232        evdw_p = 0.0D0
1233        evdw_m = 0.0D0
1234 c DIAGNOSTICS
1235 ccccc      energy_dec=.false.
1236 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1237 c      lprn   = .false.
1238 c     if (icall.eq.0) lprn=.false.
1239 c END DIAGNOSTICS
1240 c      ind = 0
1241        DO i = iatsc_s, iatsc_e
1242         itypi  = itype(i)
1243 c        itypi1 = itype(i+1)
1244         dxi    = dc_norm(1,nres+i)
1245         dyi    = dc_norm(2,nres+i)
1246         dzi    = dc_norm(3,nres+i)
1247 c        dsci_inv=dsc_inv(itypi)
1248         dsci_inv = vbld_inv(i+nres)
1249 c        DO k = 1, 3
1250 c         ctail(k,1) = c(k, i+nres)
1251 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1252 c        END DO
1253         xi=c(1,nres+i)
1254         yi=c(2,nres+i)
1255         zi=c(3,nres+i)
1256 c!-------------------------------------------------------------------
1257 C Calculate SC interaction energy.
1258         DO iint = 1, nint_gr(i)
1259          DO j = istart(i,iint), iend(i,iint)
1260 c! initialize variables for electrostatic gradients
1261           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1262 c            ind=ind+1
1263 c            dscj_inv = dsc_inv(itypj)
1264           dscj_inv = vbld_inv(j+nres)
1265 c! rij holds 1/(distance of Calpha atoms)
1266           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1267           rij  = dsqrt(rrij)
1268 c!-------------------------------------------------------------------
1269 C Calculate angle-dependent terms of energy and contributions to their
1270 C derivatives.
1271
1272 #ifdef CHECK_MOMO
1273 c!      DO troll = 10, 5000
1274 c!      om1    = 0.0d0
1275 c!      om2    = 0.0d0
1276 c!      om12   = 1.0d0
1277 c!      sqom1  = om1 * om1
1278 c!      sqom2  = om2 * om2
1279 c!      sqom12 = om12 * om12
1280 c!      rij    = 5.0d0 / troll
1281 c!      rrij   = rij * rij
1282 c!      Rtail  = troll / 5.0d0
1283 c!      Rhead  = troll / 5.0d0
1284 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1285 c!      Rtail = dsqrt((Rtail**2)
1286 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1287 c!      rij = 1.0d0/Rtail
1288 c!      rrij = rij * rij
1289 #endif
1290           CALL sc_angular
1291 c! this should be in elgrad_init but om's are calculated by sc_angular
1292 c! which in turn is used by older potentials
1293 c! which proves how tangled UNRES code is >.<
1294 c! om = omega, sqom = om^2
1295           sqom1  = om1 * om1
1296           sqom2  = om2 * om2
1297           sqom12 = om12 * om12
1298
1299 c! now we calculate EGB - Gey-Berne
1300 c! It will be summed up in evdwij and saved in evdw
1301           sigsq     = 1.0D0  / sigsq
1302           sig       = sig0ij * dsqrt(sigsq)
1303 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1304           rij_shift = Rtail - sig + sig0ij
1305           IF (rij_shift.le.0.0D0) THEN
1306            evdw = 1.0D20
1307            RETURN
1308           END IF
1309           sigder = -sig * sigsq
1310           rij_shift = 1.0D0 / rij_shift
1311           fac       = rij_shift**expon
1312           c1        = fac  * fac * aa(itypi,itypj)
1313 c!          c1        = 0.0d0
1314           c2        = fac  * bb(itypi,itypj)
1315 c!          c2        = 0.0d0
1316           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1317           eps2der   = eps3rt * evdwij
1318           eps3der   = eps2rt * evdwij
1319 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1320           evdwij    = eps2rt * eps3rt * evdwij
1321 c!      evdwij = 0.0d0
1322 c!      write (*,*) "Gey Berne = ", evdwij
1323 #ifdef TSCSC
1324           IF (bb(itypi,itypj).gt.0) THEN
1325            evdw_p = evdw_p + evdwij
1326           ELSE
1327            evdw_m = evdw_m + evdwij
1328           END IF
1329 #else
1330           evdw = evdw
1331      &         + evdwij
1332 #endif
1333 c!-------------------------------------------------------------------
1334 c! Calculate some components of GGB
1335           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1336           fac    = -expon * (c1 + evdwij) * rij_shift
1337           sigder = fac * sigder
1338 c!          fac    = rij * fac
1339 c! Calculate distance derivative
1340 c!          gg(1) = xj * fac
1341 c!          gg(2) = yj * fac
1342 c!          gg(3) = zj * fac
1343           gg(1) = fac
1344           gg(2) = fac
1345           gg(3) = fac
1346 c!      write (*,*) "gg(1) = ", gg(1)
1347 c!      write (*,*) "gg(2) = ", gg(2)
1348 c!      write (*,*) "gg(3) = ", gg(3)
1349 c! The angular derivatives of GGB are brought together in sc_grad
1350 c!-------------------------------------------------------------------
1351 c! Fcav
1352 c!
1353 c! Catch gly-gly interactions to skip calculation of something that
1354 c! does not exist
1355
1356       IF (itypi.eq.10.and.itypj.eq.10) THEN
1357        Fcav = 0.0d0
1358        dFdR = 0.0d0
1359        dCAVdOM1  = 0.0d0
1360        dCAVdOM2  = 0.0d0
1361        dCAVdOM12 = 0.0d0
1362       ELSE
1363
1364 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1365        fac = chis1 * sqom1 + chis2 * sqom2
1366      &     - 2.0d0 * chis12 * om1 * om2 * om12
1367 c! we will use pom later in Gcav, so dont mess with it!
1368        pom = 1.0d0 - chis1 * chis2 * sqom12
1369
1370        Lambf = (1.0d0 - (fac / pom))
1371        Lambf = dsqrt(Lambf)
1372
1373
1374        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1375 c!       write (*,*) "sparrow = ", sparrow
1376        Chif = Rtail * sparrow
1377        ChiLambf = Chif * Lambf
1378        eagle = dsqrt(ChiLambf)
1379        bat = ChiLambf ** 11.0d0
1380
1381        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1382        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1383        botsq = bot * bot
1384
1385 c!      write (*,*) "sig1 = ",sig1
1386 c!      write (*,*) "sig2 = ",sig2
1387 c!      write (*,*) "Rtail = ",Rtail
1388 c!      write (*,*) "sparrow = ",sparrow
1389 c!      write (*,*) "Chis1 = ", chis1
1390 c!      write (*,*) "Chis2 = ", chis2
1391 c!      write (*,*) "Chis12 = ", chis12
1392 c!      write (*,*) "om1 = ", om1
1393 c!      write (*,*) "om2 = ", om2
1394 c!      write (*,*) "om12 = ", om12
1395 c!      write (*,*) "sqom1 = ", sqom1
1396 c!      write (*,*) "sqom2 = ", sqom2
1397 c!      write (*,*) "sqom12 = ", sqom12
1398 c!      write (*,*) "Lambf = ",Lambf
1399 c!      write (*,*) "b1 = ",b1
1400 c!      write (*,*) "b2 = ",b2
1401 c!      write (*,*) "b3 = ",b3
1402 c!      write (*,*) "b4 = ",b4
1403 c!      write (*,*) "top = ",top
1404 c!      write (*,*) "bot = ",bot
1405        Fcav = top / bot
1406 c!       Fcav = 0.0d0
1407 c!      write (*,*) "Fcav = ", Fcav
1408 c!-------------------------------------------------------------------
1409 c! derivative of Fcav is Gcav...
1410 c!---------------------------------------------------
1411
1412        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1413        dbot = 12.0d0 * b4 * bat * Lambf
1414        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1415 c!       dFdR = 0.0d0
1416 c!      write (*,*) "dFcav/dR = ", dFdR
1417
1418        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1419        dbot = 12.0d0 * b4 * bat * Chif
1420        eagle = Lambf * pom
1421        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1422        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1423        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1424      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1425
1426        dFdL = ((dtop * bot - top * dbot) / botsq)
1427 c!       dFdL = 0.0d0
1428        dCAVdOM1  = dFdL * ( dFdOM1 )
1429        dCAVdOM2  = dFdL * ( dFdOM2 )
1430        dCAVdOM12 = dFdL * ( dFdOM12 )
1431 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1432 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1433 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1434 c!      write (*,*) ""
1435 c!-------------------------------------------------------------------
1436 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1437 c! Pom is used here to project the gradient vector into
1438 c! cartesian coordinates and at the same time contains
1439 c! dXhb/dXsc derivative (for charged amino acids
1440 c! location of hydrophobic centre of interaction is not
1441 c! the same as geometric centre of side chain, this
1442 c! derivative takes that into account)
1443 c! derivatives of omega angles will be added in sc_grad
1444
1445        DO k= 1, 3
1446         ertail(k) = Rtail_distance(k)/Rtail
1447        END DO
1448        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1449        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1450        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1451        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1452        DO k = 1, 3
1453 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1454 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1455         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1456         gvdwx(k,i) = gvdwx(k,i)
1457      &             - (( dFdR + gg(k) ) * pom)
1458 c!     &             - ( dFdR * pom )
1459         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1460         gvdwx(k,j) = gvdwx(k,j)
1461      &             + (( dFdR + gg(k) ) * pom)
1462 c!     &             + ( dFdR * pom )
1463
1464         gvdwc(k,i) = gvdwc(k,i)
1465      &             - (( dFdR + gg(k) ) * ertail(k))
1466 c!     &             - ( dFdR * ertail(k))
1467
1468         gvdwc(k,j) = gvdwc(k,j)
1469      &             + (( dFdR + gg(k) ) * ertail(k))
1470 c!     &             + ( dFdR * ertail(k))
1471
1472         gg(k) = 0.0d0
1473 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1474 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1475       END DO
1476
1477 c!-------------------------------------------------------------------
1478 c! Compute head-head and head-tail energies for each state
1479
1480           isel = iabs(Qi) + iabs(Qj)
1481           IF (isel.eq.0) THEN
1482 c! No charges - do nothing
1483            eheadtail = 0.0d0
1484
1485           ELSE IF (isel.eq.4) THEN
1486 c! Calculate dipole-dipole interactions
1487            CALL edd(ecl)
1488            eheadtail = ECL
1489
1490           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1491 c! Charge-nonpolar interactions
1492            CALL eqn(epol)
1493            eheadtail = epol
1494
1495           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1496 c! Nonpolar-charge interactions
1497            CALL enq(epol)
1498            eheadtail = epol
1499
1500           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1501 c! Charge-dipole interactions
1502            CALL eqd(ecl, elj, epol)
1503            eheadtail = ECL + elj + epol
1504
1505           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1506 c! Dipole-charge interactions
1507            CALL edq(ecl, elj, epol)
1508            eheadtail = ECL + elj + epol
1509
1510           ELSE IF ((isel.eq.2.and.
1511      &          iabs(Qi).eq.1).and.
1512      &          nstate(itypi,itypj).eq.1) THEN
1513 c! Same charge-charge interaction ( +/+ or -/- )
1514            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1515            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1516
1517           ELSE IF ((isel.eq.2.and.
1518      &          iabs(Qi).eq.1).and.
1519      &          nstate(itypi,itypj).ne.1) THEN
1520 c! Different charge-charge interaction ( +/- or -/+ )
1521            CALL energy_quad
1522      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1523           END IF
1524        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1525 c!      write (*,*) "evdw = ", evdw
1526 c!      write (*,*) "Fcav = ", Fcav
1527 c!      write (*,*) "eheadtail = ", eheadtail
1528        evdw = evdw
1529      &      + Fcav
1530      &      + eheadtail
1531        ij=icant(itypi,itypj)
1532        eneps_temp(1,ij)=eneps_temp(1,ij)+evdwij
1533        eneps_temp(2,ij)=eneps_temp(2,ij)+Fcav
1534        eneps_temp(3,ij)=eheadtail
1535        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1536      &  restyp(itype(i)),i,restyp(itype(j)),j,
1537      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1538      &  Equad,evdw
1539        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1540      &  restyp(itype(i)),i,restyp(itype(j)),j,
1541      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1542      &  Equad,evdw
1543 #ifdef CHECK_MOMO
1544        evdw = 0.0d0
1545        END DO ! troll
1546 #endif
1547
1548 c!-------------------------------------------------------------------
1549 c! As all angular derivatives are done, now we sum them up,
1550 c! then transform and project into cartesian vectors and add to gvdwc
1551 c! We call sc_grad always, with the exception of +/- interaction.
1552 c! This is because energy_quad subroutine needs to handle
1553 c! this job in his own way.
1554 c! This IS probably not very efficient and SHOULD be optimised
1555 c! but it will require major restructurization of emomo
1556 c! so it will be left as it is for now
1557 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1558        IF (nstate(itypi,itypj).eq.1) THEN
1559 #ifdef TSCSC
1560         IF (bb(itypi,itypj).gt.0) THEN
1561          CALL sc_grad
1562         ELSE
1563          CALL sc_grad_T
1564         END IF
1565 #else
1566         CALL sc_grad
1567 #endif
1568        END IF
1569 c!-------------------------------------------------------------------
1570 c! NAPISY KONCOWE
1571          END DO   ! j
1572         END DO    ! iint
1573        END DO     ! i
1574 c      write (iout,*) "Number of loop steps in EGB:",ind
1575 c      energy_dec=.false.
1576        RETURN
1577       END SUBROUTINE emomo
1578 c! END OF MOMO
1579 C-----------------------------------------------------------------------------
1580       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1581        IMPLICIT NONE
1582        INCLUDE 'DIMENSIONS'
1583        INCLUDE 'DIMENSIONS.ZSCOPT'
1584        INCLUDE 'COMMON.CALC'
1585        INCLUDE 'COMMON.CHAIN'
1586        INCLUDE 'COMMON.CONTROL'
1587        INCLUDE 'COMMON.DERIV'
1588        INCLUDE 'COMMON.EMP'
1589        INCLUDE 'COMMON.GEO'
1590        INCLUDE 'COMMON.INTERACT'
1591        INCLUDE 'COMMON.IOUNITS'
1592        INCLUDE 'COMMON.LOCAL'
1593        INCLUDE 'COMMON.NAMES'
1594        INCLUDE 'COMMON.VAR'
1595        double precision scalar, facd3, facd4, federmaus, adler
1596 c! Epol and Gpol analytical parameters
1597        alphapol1 = alphapol(itypi,itypj)
1598        alphapol2 = alphapol(itypj,itypi)
1599 c! Fisocav and Gisocav analytical parameters
1600        al1  = alphiso(1,itypi,itypj)
1601        al2  = alphiso(2,itypi,itypj)
1602        al3  = alphiso(3,itypi,itypj)
1603        al4  = alphiso(4,itypi,itypj)
1604        csig = (1.0d0
1605      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1606      &      + sigiso2(itypi,itypj)**2.0d0))
1607 c!
1608        pis  = sig0head(itypi,itypj)
1609        eps_head = epshead(itypi,itypj)
1610        Rhead_sq = Rhead * Rhead
1611 c! R1 - distance between head of ith side chain and tail of jth sidechain
1612 c! R2 - distance between head of jth side chain and tail of ith sidechain
1613        R1 = 0.0d0
1614        R2 = 0.0d0
1615        DO k = 1, 3
1616 c! Calculate head-to-tail distances needed by Epol
1617         R1=R1+(ctail(k,2)-chead(k,1))**2
1618         R2=R2+(chead(k,2)-ctail(k,1))**2
1619        END DO
1620 c! Pitagoras
1621        R1 = dsqrt(R1)
1622        R2 = dsqrt(R2)
1623
1624 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1625 c!     &        +dhead(1,1,itypi,itypj))**2))
1626 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1627 c!     &        +dhead(2,1,itypi,itypj))**2))
1628 c!-------------------------------------------------------------------
1629 c! Coulomb electrostatic interaction
1630        Ecl = (332.0d0 * Qij) / Rhead
1631 c! derivative of Ecl is Gcl...
1632        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1633        dGCLdOM1 = 0.0d0
1634        dGCLdOM2 = 0.0d0
1635        dGCLdOM12 = 0.0d0
1636 c!-------------------------------------------------------------------
1637 c! Generalised Born Solvent Polarization
1638 c! Charged head polarizes the solvent
1639        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1640        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1641        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1642 c! Derivative of Egb is Ggb...
1643        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1644        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1645      &        / ( 2.0d0 * Fgb )
1646        dGGBdR = dGGBdFGB * dFGBdR
1647 c!-------------------------------------------------------------------
1648 c! Fisocav - isotropic cavity creation term
1649 c! or "how much energy it costs to put charged head in water"
1650        pom = Rhead * csig
1651        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1652        bot = (1.0d0 + al4 * pom**12.0d0)
1653        botsq = bot * bot
1654        FisoCav = top / bot
1655 c!      write (*,*) "Rhead = ",Rhead
1656 c!      write (*,*) "csig = ",csig
1657 c!      write (*,*) "pom = ",pom
1658 c!      write (*,*) "al1 = ",al1
1659 c!      write (*,*) "al2 = ",al2
1660 c!      write (*,*) "al3 = ",al3
1661 c!      write (*,*) "al4 = ",al4
1662 c!      write (*,*) "top = ",top
1663 c!      write (*,*) "bot = ",bot
1664 c! Derivative of Fisocav is GCV...
1665        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1666        dbot = 12.0d0 * al4 * pom ** 11.0d0
1667        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1668 c!-------------------------------------------------------------------
1669 c! Epol
1670 c! Polarization energy - charged heads polarize hydrophobic "neck"
1671        MomoFac1 = (1.0d0 - chi1 * sqom2)
1672        MomoFac2 = (1.0d0 - chi2 * sqom1)
1673        RR1  = ( R1 * R1 ) / MomoFac1
1674        RR2  = ( R2 * R2 ) / MomoFac2
1675        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1676        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1677        fgb1 = sqrt( RR1 + a12sq * ee1 )
1678        fgb2 = sqrt( RR2 + a12sq * ee2 )
1679        epol = 332.0d0 * eps_inout_fac * (
1680      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1681 c!       epol = 0.0d0
1682 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1683 c       write (*,*) "alphapol1 = ", alphapol1
1684 c       write (*,*) "alphapol2 = ", alphapol2
1685 c       write (*,*) "fgb1 = ", fgb1
1686 c       write (*,*) "fgb2 = ", fgb2
1687 c       write (*,*) "epol = ", epol
1688 c! derivative of Epol is Gpol...
1689        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1690      &          / (fgb1 ** 5.0d0)
1691        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1692      &          / (fgb2 ** 5.0d0)
1693        dFGBdR1 = ( (R1 / MomoFac1)
1694      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1695      &        / ( 2.0d0 * fgb1 )
1696        dFGBdR2 = ( (R2 / MomoFac2)
1697      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1698      &        / ( 2.0d0 * fgb2 )
1699        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1700      &          * ( 2.0d0 - 0.5d0 * ee1) )
1701      &          / ( 2.0d0 * fgb1 )
1702        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1703      &          * ( 2.0d0 - 0.5d0 * ee2) )
1704      &          / ( 2.0d0 * fgb2 )
1705        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1706 c!       dPOLdR1 = 0.0d0
1707        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1708 c!       dPOLdR2 = 0.0d0
1709        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1710 c!       dPOLdOM1 = 0.0d0
1711        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1712 c!       dPOLdOM2 = 0.0d0
1713 c!-------------------------------------------------------------------
1714 c! Elj
1715 c! Lennard-Jones 6-12 interaction between heads
1716        pom = (pis / Rhead)**6.0d0
1717        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1718 c! derivative of Elj is Glj
1719        dGLJdR = 4.0d0 * eps_head
1720      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1721      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1722 c!-------------------------------------------------------------------
1723 c! Return the results
1724 c! These things do the dRdX derivatives, that is
1725 c! allow us to change what we see from function that changes with
1726 c! distance to function that changes with LOCATION (of the interaction
1727 c! site)
1728        DO k = 1, 3
1729         erhead(k) = Rhead_distance(k)/Rhead
1730         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1731         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1732        END DO
1733
1734        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1735        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1736        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1737        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1738        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1739        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1740        facd1 = d1 * vbld_inv(i+nres)
1741        facd2 = d2 * vbld_inv(j+nres)
1742        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1743        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1744
1745 c! Now we add appropriate partial derivatives (one in each dimension)
1746        DO k = 1, 3
1747         hawk   = (erhead_tail(k,1) +
1748      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1749         condor = (erhead_tail(k,2) +
1750      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1751
1752         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1753         gvdwx(k,i) = gvdwx(k,i)
1754      &             - dGCLdR * pom
1755      &             - dGGBdR * pom
1756      &             - dGCVdR * pom
1757      &             - dPOLdR1 * hawk
1758      &             - dPOLdR2 * (erhead_tail(k,2)
1759      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1760      &             - dGLJdR * pom
1761
1762         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1763         gvdwx(k,j) = gvdwx(k,j)
1764      &             + dGCLdR * pom
1765      &             + dGGBdR * pom
1766      &             + dGCVdR * pom
1767      &             + dPOLdR1 * (erhead_tail(k,1)
1768      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1769      &             + dPOLdR2 * condor
1770      &             + dGLJdR * pom
1771
1772         gvdwc(k,i) = gvdwc(k,i)
1773      &             - dGCLdR * erhead(k)
1774      &             - dGGBdR * erhead(k)
1775      &             - dGCVdR * erhead(k)
1776      &             - dPOLdR1 * erhead_tail(k,1)
1777      &             - dPOLdR2 * erhead_tail(k,2)
1778      &             - dGLJdR * erhead(k)
1779
1780         gvdwc(k,j) = gvdwc(k,j)
1781      &             + dGCLdR * erhead(k)
1782      &             + dGGBdR * erhead(k)
1783      &             + dGCVdR * erhead(k)
1784      &             + dPOLdR1 * erhead_tail(k,1)
1785      &             + dPOLdR2 * erhead_tail(k,2)
1786      &             + dGLJdR * erhead(k)
1787
1788        END DO
1789        RETURN
1790       END SUBROUTINE eqq
1791 c!-------------------------------------------------------------------
1792       SUBROUTINE energy_quad
1793      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1794        IMPLICIT NONE
1795        INCLUDE 'DIMENSIONS'
1796        INCLUDE 'DIMENSIONS.ZSCOPT'
1797        INCLUDE 'COMMON.CALC'
1798        INCLUDE 'COMMON.CHAIN'
1799        INCLUDE 'COMMON.CONTROL'
1800        INCLUDE 'COMMON.DERIV'
1801        INCLUDE 'COMMON.EMP'
1802        INCLUDE 'COMMON.GEO'
1803        INCLUDE 'COMMON.INTERACT'
1804        INCLUDE 'COMMON.IOUNITS'
1805        INCLUDE 'COMMON.LOCAL'
1806        INCLUDE 'COMMON.NAMES'
1807        INCLUDE 'COMMON.VAR'
1808        double precision scalar
1809        double precision ener(4)
1810        double precision dcosom1(3),dcosom2(3)
1811 c! used in Epol derivatives
1812        double precision facd3, facd4
1813        double precision federmaus, adler
1814 c! Epol and Gpol analytical parameters
1815        alphapol1 = alphapol(itypi,itypj)
1816        alphapol2 = alphapol(itypj,itypi)
1817 c! Fisocav and Gisocav analytical parameters
1818        al1  = alphiso(1,itypi,itypj)
1819        al2  = alphiso(2,itypi,itypj)
1820        al3  = alphiso(3,itypi,itypj)
1821        al4  = alphiso(4,itypi,itypj)
1822        csig = (1.0d0
1823      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1824      &      + sigiso2(itypi,itypj)**2.0d0))
1825 c!
1826        w1   = wqdip(1,itypi,itypj)
1827        w2   = wqdip(2,itypi,itypj)
1828        pis  = sig0head(itypi,itypj)
1829        eps_head = epshead(itypi,itypj)
1830 c! First things first:
1831 c! We need to do sc_grad's job with GB and Fcav
1832        eom1  =
1833      &         eps2der * eps2rt_om1
1834      &       - 2.0D0 * alf1 * eps3der
1835      &       + sigder * sigsq_om1
1836      &       + dCAVdOM1
1837        eom2  =
1838      &         eps2der * eps2rt_om2
1839      &       + 2.0D0 * alf2 * eps3der
1840      &       + sigder * sigsq_om2
1841      &       + dCAVdOM2
1842        eom12 =
1843      &         evdwij  * eps1_om12
1844      &       + eps2der * eps2rt_om12
1845      &       - 2.0D0 * alf12 * eps3der
1846      &       + sigder *sigsq_om12
1847      &       + dCAVdOM12
1848 c! now some magical transformations to project gradient into
1849 c! three cartesian vectors
1850        DO k = 1, 3
1851         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1852         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1853         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1854 c! this acts on hydrophobic center of interaction
1855         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1856      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1857      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1858         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1859      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1860      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1861 c! this acts on Calpha
1862         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1863         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1864        END DO
1865 c! sc_grad is done, now we will compute
1866        eheadtail = 0.0d0
1867        eom1 = 0.0d0
1868        eom2 = 0.0d0
1869        eom12 = 0.0d0
1870
1871 c! ENERGY DEBUG
1872 c!       ii = 1
1873 c!       jj = 1
1874 c!       d1 = dhead(1, 1, itypi, itypj)
1875 c!       d2 = dhead(2, 1, itypi, itypj)
1876 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1877 c!     &        +dhead(1,ii,itypi,itypj))**2))
1878 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1879 c!     &        +dhead(2,jj,itypi,itypj))**2))
1880 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1881 c! END OF ENERGY DEBUG
1882 c*************************************************************
1883        DO istate = 1, nstate(itypi,itypj)
1884 c*************************************************************
1885         IF (istate.ne.1) THEN
1886          IF (istate.lt.3) THEN
1887           ii = 1
1888          ELSE
1889           ii = 2
1890          END IF
1891         jj = istate/ii
1892         d1 = dhead(1,ii,itypi,itypj)
1893         d2 = dhead(2,jj,itypi,itypj)
1894         DO k = 1,3
1895          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1896          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1897          Rhead_distance(k) = chead(k,2) - chead(k,1)
1898         END DO
1899 c! pitagoras (root of sum of squares)
1900         Rhead = dsqrt(
1901      &          (Rhead_distance(1)*Rhead_distance(1))
1902      &        + (Rhead_distance(2)*Rhead_distance(2))
1903      &        + (Rhead_distance(3)*Rhead_distance(3)))
1904         END IF
1905         Rhead_sq = Rhead * Rhead
1906
1907 c! R1 - distance between head of ith side chain and tail of jth sidechain
1908 c! R2 - distance between head of jth side chain and tail of ith sidechain
1909         R1 = 0.0d0
1910         R2 = 0.0d0
1911         DO k = 1, 3
1912 c! Calculate head-to-tail distances
1913          R1=R1+(ctail(k,2)-chead(k,1))**2
1914          R2=R2+(chead(k,2)-ctail(k,1))**2
1915         END DO
1916 c! Pitagoras
1917         R1 = dsqrt(R1)
1918         R2 = dsqrt(R2)
1919
1920 c! ENERGY DEBUG
1921 c!      write (*,*) "istate = ", istate
1922 c!      write (*,*) "ii = ", ii
1923 c!      write (*,*) "jj = ", jj
1924 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1925 c!     &        +dhead(1,ii,itypi,itypj))**2))
1926 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1927 c!     &        +dhead(2,jj,itypi,itypj))**2))
1928 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1929 c!      Rhead_sq = Rhead * Rhead
1930 c!      write (*,*) "d1 = ",d1
1931 c!      write (*,*) "d2 = ",d2
1932 c!      write (*,*) "R1 = ",R1
1933 c!      write (*,*) "R2 = ",R2
1934 c!      write (*,*) "Rhead = ",Rhead
1935 c! END OF ENERGY DEBUG
1936
1937 c!-------------------------------------------------------------------
1938 c! Coulomb electrostatic interaction
1939         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1940 c!        Ecl = 0.0d0
1941 c!        write (*,*) "Ecl = ", Ecl
1942 c! derivative of Ecl is Gcl...
1943         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1944 c!        dGCLdR = 0.0d0
1945         dGCLdOM1 = 0.0d0
1946         dGCLdOM2 = 0.0d0
1947         dGCLdOM12 = 0.0d0
1948 c!-------------------------------------------------------------------
1949 c! Generalised Born Solvent Polarization
1950         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1951         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1952         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1953 c!        Egb = 0.0d0
1954 c!      write (*,*) "a1*a2 = ", a12sq
1955 c!      write (*,*) "Rhead = ", Rhead
1956 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1957 c!      write (*,*) "ee = ", ee
1958 c!      write (*,*) "Fgb = ", Fgb
1959 c!      write (*,*) "fac = ", eps_inout_fac
1960 c!      write (*,*) "Qij = ", Qij
1961 c!      write (*,*) "Egb = ", Egb
1962 c! Derivative of Egb is Ggb...
1963 c! dFGBdR is used by Quad's later...
1964         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1965         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1966      &         / ( 2.0d0 * Fgb )
1967         dGGBdR = dGGBdFGB * dFGBdR
1968 c!        dGGBdR = 0.0d0
1969 c!-------------------------------------------------------------------
1970 c! Fisocav - isotropic cavity creation term
1971         pom = Rhead * csig
1972         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1973         bot = (1.0d0 + al4 * pom**12.0d0)
1974         botsq = bot * bot
1975         FisoCav = top / bot
1976 c!        FisoCav = 0.0d0
1977 c!      write (*,*) "pom = ",pom
1978 c!      write (*,*) "al1 = ",al1
1979 c!      write (*,*) "al2 = ",al2
1980 c!      write (*,*) "al3 = ",al3
1981 c!      write (*,*) "al4 = ",al4
1982 c!      write (*,*) "top = ",top
1983 c!      write (*,*) "bot = ",bot
1984 c!      write (*,*) "Fisocav = ", Fisocav
1985
1986 c! Derivative of Fisocav is GCV...
1987         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1988         dbot = 12.0d0 * al4 * pom ** 11.0d0
1989         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1990 c!        dGCVdR = 0.0d0
1991 c!-------------------------------------------------------------------
1992 c! Polarization energy
1993 c! Epol
1994         MomoFac1 = (1.0d0 - chi1 * sqom2)
1995         MomoFac2 = (1.0d0 - chi2 * sqom1)
1996         RR1  = ( R1 * R1 ) / MomoFac1
1997         RR2  = ( R2 * R2 ) / MomoFac2
1998         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1999         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
2000         fgb1 = sqrt( RR1 + a12sq * ee1 )
2001         fgb2 = sqrt( RR2 + a12sq * ee2 )
2002         epol = 332.0d0 * eps_inout_fac * (
2003      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
2004 c!        epol = 0.0d0
2005 c! derivative of Epol is Gpol...
2006         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2007      &            / (fgb1 ** 5.0d0)
2008         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2009      &            / (fgb2 ** 5.0d0)
2010         dFGBdR1 = ( (R1 / MomoFac1)
2011      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
2012      &          / ( 2.0d0 * fgb1 )
2013         dFGBdR2 = ( (R2 / MomoFac2)
2014      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
2015      &          / ( 2.0d0 * fgb2 )
2016         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2017      &           * ( 2.0d0 - 0.5d0 * ee1) )
2018      &           / ( 2.0d0 * fgb1 )
2019         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2020      &           * ( 2.0d0 - 0.5d0 * ee2) )
2021      &           / ( 2.0d0 * fgb2 )
2022         dPOLdR1 = dPOLdFGB1 * dFGBdR1
2023 c!        dPOLdR1 = 0.0d0
2024         dPOLdR2 = dPOLdFGB2 * dFGBdR2
2025 c!        dPOLdR2 = 0.0d0
2026         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2027 c!        dPOLdOM1 = 0.0d0
2028         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2029 c!        dPOLdOM2 = 0.0d0
2030 c!-------------------------------------------------------------------
2031 c! Elj
2032         pom = (pis / Rhead)**6.0d0
2033         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2034 c!        Elj = 0.0d0
2035 c! derivative of Elj is Glj
2036         dGLJdR = 4.0d0 * eps_head
2037      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2038      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2039 c!        dGLJdR = 0.0d0
2040 c!-------------------------------------------------------------------
2041 c! Equad
2042        IF (Wqd.ne.0.0d0) THEN
2043         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
2044      &        - 37.5d0  * ( sqom1 + sqom2 )
2045      &        + 157.5d0 * ( sqom1 * sqom2 )
2046      &        - 45.0d0  * om1*om2*om12
2047         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
2048         Equad = fac * Beta1
2049 c!        Equad = 0.0d0
2050 c! derivative of Equad...
2051         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
2052 c!        dQUADdR = 0.0d0
2053         dQUADdOM1 = fac
2054      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
2055 c!        dQUADdOM1 = 0.0d0
2056         dQUADdOM2 = fac
2057      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
2058 c!        dQUADdOM2 = 0.0d0
2059         dQUADdOM12 = fac
2060      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
2061 c!        dQUADdOM12 = 0.0d0
2062         ELSE
2063          Beta1 = 0.0d0
2064          Equad = 0.0d0
2065         END IF
2066 c!-------------------------------------------------------------------
2067 c! Return the results
2068 c! Angular stuff
2069         eom1 = dPOLdOM1 + dQUADdOM1
2070         eom2 = dPOLdOM2 + dQUADdOM2
2071         eom12 = dQUADdOM12
2072 c! now some magical transformations to project gradient into
2073 c! three cartesian vectors
2074         DO k = 1, 3
2075          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
2076          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
2077          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
2078         END DO
2079 c! Radial stuff
2080         DO k = 1, 3
2081          erhead(k) = Rhead_distance(k)/Rhead
2082          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2083          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2084         END DO
2085         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2086         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2087         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2088         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2089         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2090         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2091         facd1 = d1 * vbld_inv(i+nres)
2092         facd2 = d2 * vbld_inv(j+nres)
2093         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2094         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2095 c! Throw the results into gheadtail which holds gradients
2096 c! for each micro-state
2097         DO k = 1, 3
2098          hawk   = erhead_tail(k,1) +
2099      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
2100          condor = erhead_tail(k,2) +
2101      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
2102
2103          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2104 c! this acts on hydrophobic center of interaction
2105          gheadtail(k,1,1) = gheadtail(k,1,1)
2106      &                    - dGCLdR * pom
2107      &                    - dGGBdR * pom
2108      &                    - dGCVdR * pom
2109      &                    - dPOLdR1 * hawk
2110      &                    - dPOLdR2 * (erhead_tail(k,2)
2111      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2112      &                    - dGLJdR * pom
2113      &                    - dQUADdR * pom
2114      &                    - tuna(k)
2115      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2116      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2117
2118          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2119 c! this acts on hydrophobic center of interaction
2120          gheadtail(k,2,1) = gheadtail(k,2,1)
2121      &                    + dGCLdR * pom
2122      &                    + dGGBdR * pom
2123      &                    + dGCVdR * pom
2124      &                    + dPOLdR1 * (erhead_tail(k,1)
2125      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2126      &                    + dPOLdR2 * condor
2127      &                    + dGLJdR * pom
2128      &                    + dQUADdR * pom
2129      &                    + tuna(k)
2130      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2131      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2132
2133 c! this acts on Calpha
2134          gheadtail(k,3,1) = gheadtail(k,3,1)
2135      &                    - dGCLdR * erhead(k)
2136      &                    - dGGBdR * erhead(k)
2137      &                    - dGCVdR * erhead(k)
2138      &                    - dPOLdR1 * erhead_tail(k,1)
2139      &                    - dPOLdR2 * erhead_tail(k,2)
2140      &                    - dGLJdR * erhead(k)
2141      &                    - dQUADdR * erhead(k)
2142      &                    - tuna(k)
2143
2144 c! this acts on Calpha
2145          gheadtail(k,4,1) = gheadtail(k,4,1)
2146      &                    + dGCLdR * erhead(k)
2147      &                    + dGGBdR * erhead(k)
2148      &                    + dGCVdR * erhead(k)
2149      &                    + dPOLdR1 * erhead_tail(k,1)
2150      &                    + dPOLdR2 * erhead_tail(k,2)
2151      &                    + dGLJdR * erhead(k)
2152      &                    + dQUADdR * erhead(k)
2153      &                    + tuna(k)
2154         END DO
2155 c!      write(*,*) "ECL = ", Ecl
2156 c!      write(*,*) "Egb = ", Egb
2157 c!      write(*,*) "Epol = ", Epol
2158 c!      write(*,*) "Fisocav = ", Fisocav
2159 c!      write(*,*) "Elj = ", Elj
2160 c!      write(*,*) "Equad = ", Equad
2161 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2162 c!      write(*,*) "eheadtail = ", eheadtail
2163 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2164 c!      write(*,*) "dGCLdR = ", dGCLdR
2165 c!      write(*,*) "dGGBdR = ", dGGBdR
2166 c!      write(*,*) "dGCVdR = ", dGCVdR
2167 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2168 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2169 c!      write(*,*) "dGLJdR = ", dGLJdR
2170 c!      write(*,*) "dQUADdR = ", dQUADdR
2171 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2172         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2173         eheadtail = eheadtail
2174      &            + wstate(istate, itypi, itypj)
2175      &            * dexp(-betaT * ener(istate))
2176 c! foreach cartesian dimension
2177         DO k = 1, 3
2178 c! foreach of two gvdwx and gvdwc
2179          DO l = 1, 4
2180           gheadtail(k,l,2) = gheadtail(k,l,2)
2181      &                     + wstate( istate, itypi, itypj )
2182      &                     * dexp(-betaT * ener(istate))
2183      &                     * gheadtail(k,l,1)
2184           gheadtail(k,l,1) = 0.0d0
2185          END DO
2186         END DO
2187        END DO
2188 c! Here ended the gigantic DO istate = 1, 4, which starts
2189 c! at the beggining of the subroutine
2190
2191        DO k = 1, 3
2192         DO l = 1, 4
2193          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2194         END DO
2195         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2196         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2197         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2198         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2199         DO l = 1, 4
2200          gheadtail(k,l,1) = 0.0d0
2201          gheadtail(k,l,2) = 0.0d0
2202         END DO
2203        END DO
2204        eheadtail = (-dlog(eheadtail)) / betaT
2205        dPOLdOM1 = 0.0d0
2206        dPOLdOM2 = 0.0d0
2207        dQUADdOM1 = 0.0d0
2208        dQUADdOM2 = 0.0d0
2209        dQUADdOM12 = 0.0d0
2210        RETURN
2211       END SUBROUTINE energy_quad
2212 c!-------------------------------------------------------------------
2213       SUBROUTINE eqn(Epol)
2214       IMPLICIT NONE
2215       INCLUDE 'DIMENSIONS'
2216       INCLUDE 'DIMENSIONS.ZSCOPT'
2217       INCLUDE 'COMMON.CALC'
2218       INCLUDE 'COMMON.CHAIN'
2219       INCLUDE 'COMMON.CONTROL'
2220       INCLUDE 'COMMON.DERIV'
2221       INCLUDE 'COMMON.EMP'
2222       INCLUDE 'COMMON.GEO'
2223       INCLUDE 'COMMON.INTERACT'
2224       INCLUDE 'COMMON.IOUNITS'
2225       INCLUDE 'COMMON.LOCAL'
2226       INCLUDE 'COMMON.NAMES'
2227       INCLUDE 'COMMON.VAR'
2228       double precision scalar, facd4, federmaus
2229       alphapol1 = alphapol(itypi,itypj)
2230 c! R1 - distance between head of ith side chain and tail of jth sidechain
2231        R1 = 0.0d0
2232        DO k = 1, 3
2233 c! Calculate head-to-tail distances
2234         R1=R1+(ctail(k,2)-chead(k,1))**2
2235        END DO
2236 c! Pitagoras
2237        R1 = dsqrt(R1)
2238
2239 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2240 c!     &        +dhead(1,1,itypi,itypj))**2))
2241 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2242 c!     &        +dhead(2,1,itypi,itypj))**2))
2243 c--------------------------------------------------------------------
2244 c Polarization energy
2245 c Epol
2246        MomoFac1 = (1.0d0 - chi1 * sqom2)
2247        RR1  = R1 * R1 / MomoFac1
2248        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2249        fgb1 = sqrt( RR1 + a12sq * ee1)
2250        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2251 c!       epol = 0.0d0
2252 c!------------------------------------------------------------------
2253 c! derivative of Epol is Gpol...
2254        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2255      &          / (fgb1 ** 5.0d0)
2256        dFGBdR1 = ( (R1 / MomoFac1)
2257      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2258      &        / ( 2.0d0 * fgb1 )
2259        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2260      &          * (2.0d0 - 0.5d0 * ee1) )
2261      &          / (2.0d0 * fgb1)
2262        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2263 c!       dPOLdR1 = 0.0d0
2264        dPOLdOM1 = 0.0d0
2265        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2266 c!       dPOLdOM2 = 0.0d0
2267 c!-------------------------------------------------------------------
2268 c! Return the results
2269 c! (see comments in Eqq)
2270        DO k = 1, 3
2271         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2272        END DO
2273        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2274        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2275        facd1 = d1 * vbld_inv(i+nres)
2276        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2277
2278        DO k = 1, 3
2279         hawk = (erhead_tail(k,1) +
2280      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2281
2282         gvdwx(k,i) = gvdwx(k,i)
2283      &             - dPOLdR1 * hawk
2284         gvdwx(k,j) = gvdwx(k,j)
2285      &             + dPOLdR1 * (erhead_tail(k,1)
2286      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2287
2288         gvdwc(k,i) = gvdwc(k,i)
2289      &             - dPOLdR1 * erhead_tail(k,1)
2290         gvdwc(k,j) = gvdwc(k,j)
2291      &             + dPOLdR1 * erhead_tail(k,1)
2292
2293        END DO
2294        RETURN
2295       END SUBROUTINE eqn
2296
2297
2298 c!-------------------------------------------------------------------
2299
2300
2301
2302       SUBROUTINE enq(Epol)
2303        IMPLICIT NONE
2304        INCLUDE 'DIMENSIONS'
2305        INCLUDE 'DIMENSIONS.ZSCOPT'
2306        INCLUDE 'COMMON.CALC'
2307        INCLUDE 'COMMON.CHAIN'
2308        INCLUDE 'COMMON.CONTROL'
2309        INCLUDE 'COMMON.DERIV'
2310        INCLUDE 'COMMON.EMP'
2311        INCLUDE 'COMMON.GEO'
2312        INCLUDE 'COMMON.INTERACT'
2313        INCLUDE 'COMMON.IOUNITS'
2314        INCLUDE 'COMMON.LOCAL'
2315        INCLUDE 'COMMON.NAMES'
2316        INCLUDE 'COMMON.VAR'
2317        double precision scalar, facd3, adler
2318        alphapol2 = alphapol(itypj,itypi)
2319 c! R2 - distance between head of jth side chain and tail of ith sidechain
2320        R2 = 0.0d0
2321        DO k = 1, 3
2322 c! Calculate head-to-tail distances
2323         R2=R2+(chead(k,2)-ctail(k,1))**2
2324        END DO
2325 c! Pitagoras
2326        R2 = dsqrt(R2)
2327
2328 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2329 c!     &        +dhead(1,1,itypi,itypj))**2))
2330 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2331 c!     &        +dhead(2,1,itypi,itypj))**2))
2332 c------------------------------------------------------------------------
2333 c Polarization energy
2334        MomoFac2 = (1.0d0 - chi2 * sqom1)
2335        RR2  = R2 * R2 / MomoFac2
2336        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2337        fgb2 = sqrt(RR2  + a12sq * ee2)
2338        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2339 c!       epol = 0.0d0
2340 c!-------------------------------------------------------------------
2341 c! derivative of Epol is Gpol...
2342        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2343      &          / (fgb2 ** 5.0d0)
2344        dFGBdR2 = ( (R2 / MomoFac2)
2345      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2346      &        / (2.0d0 * fgb2)
2347        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2348      &          * (2.0d0 - 0.5d0 * ee2) )
2349      &          / (2.0d0 * fgb2)
2350        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2351 c!       dPOLdR2 = 0.0d0
2352        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2353 c!       dPOLdOM1 = 0.0d0
2354        dPOLdOM2 = 0.0d0
2355 c!-------------------------------------------------------------------
2356 c! Return the results
2357 c! (See comments in Eqq)
2358        DO k = 1, 3
2359         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2360        END DO
2361        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2362        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2363        facd2 = d2 * vbld_inv(j+nres)
2364        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2365        DO k = 1, 3
2366         condor = (erhead_tail(k,2)
2367      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2368
2369         gvdwx(k,i) = gvdwx(k,i)
2370      &             - dPOLdR2 * (erhead_tail(k,2)
2371      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2372         gvdwx(k,j) = gvdwx(k,j)
2373      &             + dPOLdR2 * condor
2374
2375         gvdwc(k,i) = gvdwc(k,i)
2376      &             - dPOLdR2 * erhead_tail(k,2)
2377         gvdwc(k,j) = gvdwc(k,j)
2378      &             + dPOLdR2 * erhead_tail(k,2)
2379
2380        END DO
2381       RETURN
2382       END SUBROUTINE enq
2383
2384
2385 c!-------------------------------------------------------------------
2386
2387
2388       SUBROUTINE eqd(Ecl,Elj,Epol)
2389        IMPLICIT NONE
2390        INCLUDE 'DIMENSIONS'
2391        INCLUDE 'DIMENSIONS.ZSCOPT'
2392        INCLUDE 'COMMON.CALC'
2393        INCLUDE 'COMMON.CHAIN'
2394        INCLUDE 'COMMON.CONTROL'
2395        INCLUDE 'COMMON.DERIV'
2396        INCLUDE 'COMMON.EMP'
2397        INCLUDE 'COMMON.GEO'
2398        INCLUDE 'COMMON.INTERACT'
2399        INCLUDE 'COMMON.IOUNITS'
2400        INCLUDE 'COMMON.LOCAL'
2401        INCLUDE 'COMMON.NAMES'
2402        INCLUDE 'COMMON.VAR'
2403        double precision scalar, facd4, federmaus
2404        alphapol1 = alphapol(itypi,itypj)
2405        w1        = wqdip(1,itypi,itypj)
2406        w2        = wqdip(2,itypi,itypj)
2407        pis       = sig0head(itypi,itypj)
2408        eps_head   = epshead(itypi,itypj)
2409 c!-------------------------------------------------------------------
2410 c! R1 - distance between head of ith side chain and tail of jth sidechain
2411        R1 = 0.0d0
2412        DO k = 1, 3
2413 c! Calculate head-to-tail distances
2414         R1=R1+(ctail(k,2)-chead(k,1))**2
2415        END DO
2416 c! Pitagoras
2417        R1 = dsqrt(R1)
2418
2419 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2420 c!     &        +dhead(1,1,itypi,itypj))**2))
2421 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2422 c!     &        +dhead(2,1,itypi,itypj))**2))
2423
2424 c!-------------------------------------------------------------------
2425 c! ecl
2426        sparrow  = w1 * Qi * om1
2427        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2428        Ecl = sparrow / Rhead**2.0d0
2429      &     - hawk    / Rhead**4.0d0
2430 c!-------------------------------------------------------------------
2431 c! derivative of ecl is Gcl
2432 c! dF/dr part
2433        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2434      &           + 4.0d0 * hawk    / Rhead**5.0d0
2435 c! dF/dom1
2436        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2437 c! dF/dom2
2438        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2439 c--------------------------------------------------------------------
2440 c Polarization energy
2441 c Epol
2442        MomoFac1 = (1.0d0 - chi1 * sqom2)
2443        RR1  = R1 * R1 / MomoFac1
2444        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2445        fgb1 = sqrt( RR1 + a12sq * ee1)
2446        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2447 c!       epol = 0.0d0
2448 c!------------------------------------------------------------------
2449 c! derivative of Epol is Gpol...
2450        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2451      &          / (fgb1 ** 5.0d0)
2452        dFGBdR1 = ( (R1 / MomoFac1)
2453      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2454      &        / ( 2.0d0 * fgb1 )
2455        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2456      &          * (2.0d0 - 0.5d0 * ee1) )
2457      &          / (2.0d0 * fgb1)
2458        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2459 c!       dPOLdR1 = 0.0d0
2460        dPOLdOM1 = 0.0d0
2461        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2462 c!       dPOLdOM2 = 0.0d0
2463 c!-------------------------------------------------------------------
2464 c! Elj
2465        pom = (pis / Rhead)**6.0d0
2466        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2467 c! derivative of Elj is Glj
2468        dGLJdR = 4.0d0 * eps_head
2469      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2470      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2471 c!-------------------------------------------------------------------
2472 c! Return the results
2473        DO k = 1, 3
2474         erhead(k) = Rhead_distance(k)/Rhead
2475         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2476        END DO
2477
2478        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2479        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2480        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2481        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2482        facd1 = d1 * vbld_inv(i+nres)
2483        facd2 = d2 * vbld_inv(j+nres)
2484        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2485
2486        DO k = 1, 3
2487         hawk = (erhead_tail(k,1) +
2488      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2489
2490         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2491         gvdwx(k,i) = gvdwx(k,i)
2492      &             - dGCLdR * pom
2493      &             - dPOLdR1 * hawk
2494      &             - dGLJdR * pom
2495
2496         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2497         gvdwx(k,j) = gvdwx(k,j)
2498      &             + dGCLdR * pom
2499      &             + dPOLdR1 * (erhead_tail(k,1)
2500      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2501      &             + dGLJdR * pom
2502
2503
2504         gvdwc(k,i) = gvdwc(k,i)
2505      &             - dGCLdR * erhead(k)
2506      &             - dPOLdR1 * erhead_tail(k,1)
2507      &             - dGLJdR * erhead(k)
2508
2509         gvdwc(k,j) = gvdwc(k,j)
2510      &             + dGCLdR * erhead(k)
2511      &             + dPOLdR1 * erhead_tail(k,1)
2512      &             + dGLJdR * erhead(k)
2513
2514        END DO
2515        RETURN
2516       END SUBROUTINE eqd
2517
2518
2519 c!-------------------------------------------------------------------
2520
2521
2522       SUBROUTINE edq(Ecl,Elj,Epol)
2523        IMPLICIT NONE
2524        INCLUDE 'DIMENSIONS'
2525        INCLUDE 'DIMENSIONS.ZSCOPT'
2526        INCLUDE 'COMMON.CALC'
2527        INCLUDE 'COMMON.CHAIN'
2528        INCLUDE 'COMMON.CONTROL'
2529        INCLUDE 'COMMON.DERIV'
2530        INCLUDE 'COMMON.EMP'
2531        INCLUDE 'COMMON.GEO'
2532        INCLUDE 'COMMON.INTERACT'
2533        INCLUDE 'COMMON.IOUNITS'
2534        INCLUDE 'COMMON.LOCAL'
2535        INCLUDE 'COMMON.NAMES'
2536        INCLUDE 'COMMON.VAR'
2537        double precision scalar, facd3, adler
2538        alphapol2 = alphapol(itypj,itypi)
2539        w1        = wqdip(1,itypi,itypj)
2540        w2        = wqdip(2,itypi,itypj)
2541        pis       = sig0head(itypi,itypj)
2542        eps_head  = epshead(itypi,itypj)
2543 c!-------------------------------------------------------------------
2544 c! R2 - distance between head of jth side chain and tail of ith sidechain
2545        R2 = 0.0d0
2546        DO k = 1, 3
2547 c! Calculate head-to-tail distances
2548         R2=R2+(chead(k,2)-ctail(k,1))**2
2549        END DO
2550 c! Pitagoras
2551        R2 = dsqrt(R2)
2552
2553 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2554 c!     &        +dhead(1,1,itypi,itypj))**2))
2555 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2556 c!     &        +dhead(2,1,itypi,itypj))**2))
2557
2558
2559 c!-------------------------------------------------------------------
2560 c! ecl
2561        sparrow  = w1 * Qi * om1
2562        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2563        ECL = sparrow / Rhead**2.0d0
2564      &     - hawk    / Rhead**4.0d0
2565 c!-------------------------------------------------------------------
2566 c! derivative of ecl is Gcl
2567 c! dF/dr part
2568        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2569      &           + 4.0d0 * hawk    / Rhead**5.0d0
2570 c! dF/dom1
2571        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2572 c! dF/dom2
2573        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2574 c--------------------------------------------------------------------
2575 c Polarization energy
2576 c Epol
2577        MomoFac2 = (1.0d0 - chi2 * sqom1)
2578        RR2  = R2 * R2 / MomoFac2
2579        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2580        fgb2 = sqrt(RR2  + a12sq * ee2)
2581        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2582 c!       epol = 0.0d0
2583 c! derivative of Epol is Gpol...
2584        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2585      &          / (fgb2 ** 5.0d0)
2586        dFGBdR2 = ( (R2 / MomoFac2)
2587      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2588      &        / (2.0d0 * fgb2)
2589        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2590      &          * (2.0d0 - 0.5d0 * ee2) )
2591      &          / (2.0d0 * fgb2)
2592        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2593 c!       dPOLdR2 = 0.0d0
2594        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2595 c!       dPOLdOM1 = 0.0d0
2596        dPOLdOM2 = 0.0d0
2597 c!-------------------------------------------------------------------
2598 c! Elj
2599        pom = (pis / Rhead)**6.0d0
2600        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2601 c! derivative of Elj is Glj
2602        dGLJdR = 4.0d0 * eps_head
2603      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2604      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2605 c!-------------------------------------------------------------------
2606 c! Return the results
2607 c! (see comments in Eqq)
2608        DO k = 1, 3
2609         erhead(k) = Rhead_distance(k)/Rhead
2610         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2611        END DO
2612        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2613        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2614        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2615        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2616        facd1 = d1 * vbld_inv(i+nres)
2617        facd2 = d2 * vbld_inv(j+nres)
2618        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2619
2620        DO k = 1, 3
2621         condor = (erhead_tail(k,2)
2622      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2623
2624         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2625         gvdwx(k,i) = gvdwx(k,i)
2626      &             - dGCLdR * pom
2627      &             - dPOLdR2 * (erhead_tail(k,2)
2628      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2629      &             - dGLJdR * pom
2630
2631         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2632         gvdwx(k,j) = gvdwx(k,j)
2633      &             + dGCLdR * pom
2634      &             + dPOLdR2 * condor
2635      &             + dGLJdR * pom
2636
2637
2638         gvdwc(k,i) = gvdwc(k,i)
2639      &             - dGCLdR * erhead(k)
2640      &             - dPOLdR2 * erhead_tail(k,2)
2641      &             - dGLJdR * erhead(k)
2642
2643         gvdwc(k,j) = gvdwc(k,j)
2644      &             + dGCLdR * erhead(k)
2645      &             + dPOLdR2 * erhead_tail(k,2)
2646      &             + dGLJdR * erhead(k)
2647
2648        END DO
2649        RETURN
2650       END SUBROUTINE edq
2651
2652
2653 C--------------------------------------------------------------------
2654
2655
2656       SUBROUTINE edd(ECL)
2657        IMPLICIT NONE
2658        INCLUDE 'DIMENSIONS'
2659        INCLUDE 'DIMENSIONS.ZSCOPT'
2660        INCLUDE 'COMMON.CALC'
2661        INCLUDE 'COMMON.CHAIN'
2662        INCLUDE 'COMMON.CONTROL'
2663        INCLUDE 'COMMON.DERIV'
2664        INCLUDE 'COMMON.EMP'
2665        INCLUDE 'COMMON.GEO'
2666        INCLUDE 'COMMON.INTERACT'
2667        INCLUDE 'COMMON.IOUNITS'
2668        INCLUDE 'COMMON.LOCAL'
2669        INCLUDE 'COMMON.NAMES'
2670        INCLUDE 'COMMON.VAR'
2671        double precision scalar
2672 c!       csig = sigiso(itypi,itypj)
2673        w1 = wqdip(1,itypi,itypj)
2674        w2 = wqdip(2,itypi,itypj)
2675 c!-------------------------------------------------------------------
2676 c! ECL
2677        fac = (om12 - 3.0d0 * om1 * om2)
2678        c1 = (w1 / (Rhead**3.0d0)) * fac
2679        c2 = (w2 / Rhead ** 6.0d0)
2680      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2681        ECL = c1 - c2
2682 c!       write (*,*) "w1 = ", w1
2683 c!       write (*,*) "w2 = ", w2
2684 c!       write (*,*) "om1 = ", om1
2685 c!       write (*,*) "om2 = ", om2
2686 c!       write (*,*) "om12 = ", om12
2687 c!       write (*,*) "fac = ", fac
2688 c!       write (*,*) "c1 = ", c1
2689 c!       write (*,*) "c2 = ", c2
2690 c!       write (*,*) "Ecl = ", Ecl
2691 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2692 c!       write (*,*) "c2_2 = ",
2693 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2694 c!-------------------------------------------------------------------
2695 c! dervative of ECL is GCL...
2696 c! dECL/dr
2697        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2698        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2699      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2700        dGCLdR = c1 - c2
2701 c! dECL/dom1
2702        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2703        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2704      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2705        dGCLdOM1 = c1 - c2
2706 c! dECL/dom2
2707        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2708        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2709      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2710        dGCLdOM2 = c1 - c2
2711 c! dECL/dom12
2712        c1 = w1 / (Rhead ** 3.0d0)
2713        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2714        dGCLdOM12 = c1 - c2
2715 c!-------------------------------------------------------------------
2716 c! Return the results
2717 c! (see comments in Eqq)
2718        DO k= 1, 3
2719         erhead(k) = Rhead_distance(k)/Rhead
2720        END DO
2721        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2722        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2723        facd1 = d1 * vbld_inv(i+nres)
2724        facd2 = d2 * vbld_inv(j+nres)
2725        DO k = 1, 3
2726
2727         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2728         gvdwx(k,i) = gvdwx(k,i)
2729      &             - dGCLdR * pom
2730         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2731         gvdwx(k,j) = gvdwx(k,j)
2732      &             + dGCLdR * pom
2733
2734         gvdwc(k,i) = gvdwc(k,i)
2735      &             - dGCLdR * erhead(k)
2736         gvdwc(k,j) = gvdwc(k,j)
2737      &             + dGCLdR * erhead(k)
2738        END DO
2739        RETURN
2740       END SUBROUTINE edd
2741
2742
2743 c!-------------------------------------------------------------------
2744
2745
2746       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2747        IMPLICIT NONE
2748 c! maxres
2749        INCLUDE 'DIMENSIONS'
2750        INCLUDE 'DIMENSIONS.ZSCOPT'
2751 c! itypi, itypj, i, j, k, l, chead,
2752        INCLUDE 'COMMON.CALC'
2753 c! c, nres, dc_norm
2754        INCLUDE 'COMMON.CHAIN'
2755 c! gradc, gradx
2756        INCLUDE 'COMMON.DERIV'
2757 c! electrostatic gradients-specific variables
2758        INCLUDE 'COMMON.EMP'
2759 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2760        INCLUDE 'COMMON.INTERACT'
2761 c! t_bath, Rb
2762 c       INCLUDE 'COMMON.MD'
2763 c! io for debug, disable it in final builds
2764        INCLUDE 'COMMON.IOUNITS'
2765        double precision Rb /1.987D-3/
2766 c!-------------------------------------------------------------------
2767 c! Variable Init
2768
2769 c! what amino acid is the aminoacid j'th?
2770        itypj = itype(j)
2771 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2772 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2773 c!       t_bath = 300
2774 c!       BetaT = 1.0d0 / (t_bath * Rb)
2775        BetaT = 1.0d0 / (298.0d0 * Rb)
2776 c! Gay-berne var's
2777        sig0ij = sigma( itypi,itypj )
2778        chi1   = chi( itypi, itypj )
2779        chi2   = chi( itypj, itypi )
2780        chi12  = chi1 * chi2
2781        chip1  = chipp( itypi, itypj )
2782        chip2  = chipp( itypj, itypi )
2783        chip12 = chip1 * chip2
2784 c! not used by momo potential, but needed by sc_angular which is shared
2785 c! by all energy_potential subroutines
2786        alf1   = 0.0d0
2787        alf2   = 0.0d0
2788        alf12  = 0.0d0
2789 c! location, location, location
2790        xj  = c( 1, nres+j ) - xi
2791        yj  = c( 2, nres+j ) - yi
2792        zj  = c( 3, nres+j ) - zi
2793        dxj = dc_norm( 1, nres+j )
2794        dyj = dc_norm( 2, nres+j )
2795        dzj = dc_norm( 3, nres+j )
2796 c! distance from center of chain(?) to polar/charged head
2797 c!       write (*,*) "istate = ", 1
2798 c!       write (*,*) "ii = ", 1
2799 c!       write (*,*) "jj = ", 1
2800        d1 = dhead(1, 1, itypi, itypj)
2801        d2 = dhead(2, 1, itypi, itypj)
2802 c! ai*aj from Fgb
2803        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2804 c!       a12sq = a12sq * a12sq
2805 c! charge of amino acid itypi is...
2806        Qi  = icharge(itypi)
2807        Qj  = icharge(itypj)
2808        Qij = Qi * Qj
2809 c! chis1,2,12
2810        chis1 = chis(itypi,itypj)
2811        chis2 = chis(itypj,itypi)
2812        chis12 = chis1 * chis2
2813        sig1 = sigmap1(itypi,itypj)
2814        sig2 = sigmap2(itypi,itypj)
2815 c!       write (*,*) "sig1 = ", sig1
2816 c!       write (*,*) "sig2 = ", sig2
2817 c! alpha factors from Fcav/Gcav
2818        b1 = alphasur(1,itypi,itypj)
2819        b2 = alphasur(2,itypi,itypj)
2820        b3 = alphasur(3,itypi,itypj)
2821        b4 = alphasur(4,itypi,itypj)
2822 c! used to determine whether we want to do quadrupole calculations
2823        wqd = wquad(itypi, itypj)
2824 c! used by Fgb
2825        eps_in = epsintab(itypi,itypj)
2826        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2827 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2828 c!-------------------------------------------------------------------
2829 c! tail location and distance calculations
2830        Rtail = 0.0d0
2831        DO k = 1, 3
2832         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2833         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2834        END DO
2835 c! tail distances will be themselves usefull elswhere
2836 c1 (in Gcav, for example)
2837        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2838        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2839        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2840        Rtail = dsqrt(
2841      &     (Rtail_distance(1)*Rtail_distance(1))
2842      &   + (Rtail_distance(2)*Rtail_distance(2))
2843      &   + (Rtail_distance(3)*Rtail_distance(3)))
2844 c!-------------------------------------------------------------------
2845 c! Calculate location and distance between polar heads
2846 c! distance between heads
2847 c! for each one of our three dimensional space...
2848        DO k = 1,3
2849 c! location of polar head is computed by taking hydrophobic centre
2850 c! and moving by a d1 * dc_norm vector
2851 c! see unres publications for very informative images
2852         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2853         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2854 c! distance
2855 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2856 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2857         Rhead_distance(k) = chead(k,2) - chead(k,1)
2858        END DO
2859 c! pitagoras (root of sum of squares)
2860        Rhead = dsqrt(
2861      &     (Rhead_distance(1)*Rhead_distance(1))
2862      &   + (Rhead_distance(2)*Rhead_distance(2))
2863      &   + (Rhead_distance(3)*Rhead_distance(3)))
2864 c!-------------------------------------------------------------------
2865 c! zero everything that should be zero'ed
2866        Egb = 0.0d0
2867        ECL = 0.0d0
2868        Elj = 0.0d0
2869        Equad = 0.0d0
2870        Epol = 0.0d0
2871        eheadtail = 0.0d0
2872        dGCLdOM1 = 0.0d0
2873        dGCLdOM2 = 0.0d0
2874        dGCLdOM12 = 0.0d0
2875        dPOLdOM1 = 0.0d0
2876        dPOLdOM2 = 0.0d0
2877        RETURN
2878       END SUBROUTINE elgrad_init
2879
2880
2881 C-----------------------------------------------------------------------------
2882       subroutine sc_angular
2883 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2884 C om12. Called by ebp, egb, and egbv.
2885       implicit none
2886       include 'COMMON.CALC'
2887       erij(1)=xj*rij
2888       erij(2)=yj*rij
2889       erij(3)=zj*rij
2890       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2891       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2892       om12=dxi*dxj+dyi*dyj+dzi*dzj
2893       chiom12=chi12*om12
2894 C Calculate eps1(om12) and its derivative in om12
2895       faceps1=1.0D0-om12*chiom12
2896       faceps1_inv=1.0D0/faceps1
2897       eps1=dsqrt(faceps1_inv)
2898 C Following variable is eps1*deps1/dom12
2899       eps1_om12=faceps1_inv*chiom12
2900 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2901 C and om12.
2902       om1om2=om1*om2
2903       chiom1=chi1*om1
2904       chiom2=chi2*om2
2905       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2906       sigsq=1.0D0-facsig*faceps1_inv
2907       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2908       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2909       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2910 C Calculate eps2 and its derivatives in om1, om2, and om12.
2911       chipom1=chip1*om1
2912       chipom2=chip2*om2
2913       chipom12=chip12*om12
2914       facp=1.0D0-om12*chipom12
2915       facp_inv=1.0D0/facp
2916       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2917 C Following variable is the square root of eps2
2918       eps2rt=1.0D0-facp1*facp_inv
2919 C Following three variables are the derivatives of the square root of eps
2920 C in om1, om2, and om12.
2921       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2922       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2923       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2924 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2925       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2926 C Calculate whole angle-dependent part of epsilon and contributions
2927 C to its derivatives
2928       return
2929       end
2930 C----------------------------------------------------------------------------
2931       subroutine sc_grad
2932       implicit real*8 (a-h,o-z)
2933       include 'DIMENSIONS'
2934       include 'DIMENSIONS.ZSCOPT'
2935       include 'COMMON.CHAIN'
2936       include 'COMMON.DERIV'
2937       include 'COMMON.CALC'
2938       double precision dcosom1(3),dcosom2(3)
2939       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2940       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2941       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2942      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2943       do k=1,3
2944         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2945         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2946       enddo
2947       do k=1,3
2948         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2949       enddo
2950       do k=1,3
2951         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2952      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2953      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2954         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2955      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2956      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2957       enddo
2958 C
2959 C Calculate the components of the gradient in DC and X
2960 C
2961       do k=i,j-1
2962         do l=1,3
2963           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2964         enddo
2965       enddo
2966       return
2967       end
2968 c------------------------------------------------------------------------------
2969       subroutine vec_and_deriv
2970       implicit real*8 (a-h,o-z)
2971       include 'DIMENSIONS'
2972       include 'DIMENSIONS.ZSCOPT'
2973       include 'COMMON.IOUNITS'
2974       include 'COMMON.GEO'
2975       include 'COMMON.VAR'
2976       include 'COMMON.LOCAL'
2977       include 'COMMON.CHAIN'
2978       include 'COMMON.VECTORS'
2979       include 'COMMON.DERIV'
2980       include 'COMMON.INTERACT'
2981       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2982 C Compute the local reference systems. For reference system (i), the
2983 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2984 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2985       do i=1,nres-1
2986 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2987           if (i.eq.nres-1) then
2988 C Case of the last full residue
2989 C Compute the Z-axis
2990             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2991             costh=dcos(pi-theta(nres))
2992             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2993             do k=1,3
2994               uz(k,i)=fac*uz(k,i)
2995             enddo
2996             if (calc_grad) then
2997 C Compute the derivatives of uz
2998             uzder(1,1,1)= 0.0d0
2999             uzder(2,1,1)=-dc_norm(3,i-1)
3000             uzder(3,1,1)= dc_norm(2,i-1)
3001             uzder(1,2,1)= dc_norm(3,i-1)
3002             uzder(2,2,1)= 0.0d0
3003             uzder(3,2,1)=-dc_norm(1,i-1)
3004             uzder(1,3,1)=-dc_norm(2,i-1)
3005             uzder(2,3,1)= dc_norm(1,i-1)
3006             uzder(3,3,1)= 0.0d0
3007             uzder(1,1,2)= 0.0d0
3008             uzder(2,1,2)= dc_norm(3,i)
3009             uzder(3,1,2)=-dc_norm(2,i)
3010             uzder(1,2,2)=-dc_norm(3,i)
3011             uzder(2,2,2)= 0.0d0
3012             uzder(3,2,2)= dc_norm(1,i)
3013             uzder(1,3,2)= dc_norm(2,i)
3014             uzder(2,3,2)=-dc_norm(1,i)
3015             uzder(3,3,2)= 0.0d0
3016             endif
3017 C Compute the Y-axis
3018             facy=fac
3019             do k=1,3
3020               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3021             enddo
3022             if (calc_grad) then
3023 C Compute the derivatives of uy
3024             do j=1,3
3025               do k=1,3
3026                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3027      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3028                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3029               enddo
3030               uyder(j,j,1)=uyder(j,j,1)-costh
3031               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3032             enddo
3033             do j=1,2
3034               do k=1,3
3035                 do l=1,3
3036                   uygrad(l,k,j,i)=uyder(l,k,j)
3037                   uzgrad(l,k,j,i)=uzder(l,k,j)
3038                 enddo
3039               enddo
3040             enddo
3041             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3042             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3043             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3044             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3045             endif
3046           else
3047 C Other residues
3048 C Compute the Z-axis
3049             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3050             costh=dcos(pi-theta(i+2))
3051             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3052             do k=1,3
3053               uz(k,i)=fac*uz(k,i)
3054             enddo
3055             if (calc_grad) then
3056 C Compute the derivatives of uz
3057             uzder(1,1,1)= 0.0d0
3058             uzder(2,1,1)=-dc_norm(3,i+1)
3059             uzder(3,1,1)= dc_norm(2,i+1)
3060             uzder(1,2,1)= dc_norm(3,i+1)
3061             uzder(2,2,1)= 0.0d0
3062             uzder(3,2,1)=-dc_norm(1,i+1)
3063             uzder(1,3,1)=-dc_norm(2,i+1)
3064             uzder(2,3,1)= dc_norm(1,i+1)
3065             uzder(3,3,1)= 0.0d0
3066             uzder(1,1,2)= 0.0d0
3067             uzder(2,1,2)= dc_norm(3,i)
3068             uzder(3,1,2)=-dc_norm(2,i)
3069             uzder(1,2,2)=-dc_norm(3,i)
3070             uzder(2,2,2)= 0.0d0
3071             uzder(3,2,2)= dc_norm(1,i)
3072             uzder(1,3,2)= dc_norm(2,i)
3073             uzder(2,3,2)=-dc_norm(1,i)
3074             uzder(3,3,2)= 0.0d0
3075             endif
3076 C Compute the Y-axis
3077             facy=fac
3078             do k=1,3
3079               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3080             enddo
3081             if (calc_grad) then
3082 C Compute the derivatives of uy
3083             do j=1,3
3084               do k=1,3
3085                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3086      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3087                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3088               enddo
3089               uyder(j,j,1)=uyder(j,j,1)-costh
3090               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3091             enddo
3092             do j=1,2
3093               do k=1,3
3094                 do l=1,3
3095                   uygrad(l,k,j,i)=uyder(l,k,j)
3096                   uzgrad(l,k,j,i)=uzder(l,k,j)
3097                 enddo
3098               enddo
3099             enddo
3100             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3101             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3102             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3103             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3104           endif
3105           endif
3106       enddo
3107       if (calc_grad) then
3108       do i=1,nres-1
3109         vbld_inv_temp(1)=vbld_inv(i+1)
3110         if (i.lt.nres-1) then
3111           vbld_inv_temp(2)=vbld_inv(i+2)
3112         else
3113           vbld_inv_temp(2)=vbld_inv(i)
3114         endif
3115         do j=1,2
3116           do k=1,3
3117             do l=1,3
3118               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
3119               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
3120             enddo
3121           enddo
3122         enddo
3123       enddo
3124       endif
3125       return
3126       end
3127 c------------------------------------------------------------------------------
3128       subroutine set_matrices
3129       implicit real*8 (a-h,o-z)
3130       include 'DIMENSIONS'
3131 #ifdef MPI
3132       include "mpif.h"
3133       integer IERR
3134       integer status(MPI_STATUS_SIZE)
3135 #endif
3136       include 'DIMENSIONS.ZSCOPT'
3137       include 'COMMON.IOUNITS'
3138       include 'COMMON.GEO'
3139       include 'COMMON.VAR'
3140       include 'COMMON.LOCAL'
3141       include 'COMMON.CHAIN'
3142       include 'COMMON.DERIV'
3143       include 'COMMON.INTERACT'
3144       include 'COMMON.CONTACTS'
3145       include 'COMMON.TORSION'
3146       include 'COMMON.VECTORS'
3147       include 'COMMON.FFIELD'
3148       double precision auxvec(2),auxmat(2,2)
3149 C
3150 C Compute the virtual-bond-torsional-angle dependent quantities needed
3151 C to calculate the el-loc multibody terms of various order.
3152 C
3153 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
3154       do i=3,nres+1
3155         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3156           iti = itype2loc(itype(i-2))
3157         else
3158           iti=nloctyp
3159         endif
3160 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3161         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3162           iti1 = itype2loc(itype(i-1))
3163         else
3164           iti1=nloctyp
3165         endif
3166 #ifdef NEWCORR
3167         cost1=dcos(theta(i-1))
3168         sint1=dsin(theta(i-1))
3169         sint1sq=sint1*sint1
3170         sint1cub=sint1sq*sint1
3171         sint1cost1=2*sint1*cost1
3172 #ifdef DEBUG
3173         write (iout,*) "bnew1",i,iti
3174         write (iout,*) (bnew1(k,1,iti),k=1,3)
3175         write (iout,*) (bnew1(k,2,iti),k=1,3)
3176         write (iout,*) "bnew2",i,iti
3177         write (iout,*) (bnew2(k,1,iti),k=1,3)
3178         write (iout,*) (bnew2(k,2,iti),k=1,3)
3179 #endif
3180         do k=1,2
3181           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3182           b1(k,i-2)=sint1*b1k
3183           gtb1(k,i-2)=cost1*b1k-sint1sq*
3184      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3185           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3186           b2(k,i-2)=sint1*b2k
3187           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
3188      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3189         enddo
3190         do k=1,2
3191           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3192           cc(1,k,i-2)=sint1sq*aux
3193           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3194      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3195           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3196           dd(1,k,i-2)=sint1sq*aux
3197           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3198      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3199         enddo
3200         cc(2,1,i-2)=cc(1,2,i-2)
3201         cc(2,2,i-2)=-cc(1,1,i-2)
3202         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3203         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3204         dd(2,1,i-2)=dd(1,2,i-2)
3205         dd(2,2,i-2)=-dd(1,1,i-2)
3206         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3207         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3208         do k=1,2
3209           do l=1,2
3210             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3211             EE(l,k,i-2)=sint1sq*aux
3212             if (calc_grad)
3213      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3214           enddo
3215         enddo
3216         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3217         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3218         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3219         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3220         if (calc_grad) then
3221         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3222         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3223         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3224         endif
3225 c        b1tilde(1,i-2)=b1(1,i-2)
3226 c        b1tilde(2,i-2)=-b1(2,i-2)
3227 c        b2tilde(1,i-2)=b2(1,i-2)
3228 c        b2tilde(2,i-2)=-b2(2,i-2)
3229 #ifdef DEBUG
3230         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3231         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3232         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3233         write (iout,*) 'theta=', theta(i-1)
3234 #endif
3235 #else
3236         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3237           iti = itype2loc(itype(i-2))
3238         else
3239           iti=nloctyp
3240         endif
3241 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3242         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3243           iti1 = itype2loc(itype(i-1))
3244         else
3245           iti1=nloctyp
3246         endif
3247         b1(1,i-2)=b(3,iti)
3248         b1(2,i-2)=b(5,iti)
3249         b2(1,i-2)=b(2,iti)
3250         b2(2,i-2)=b(4,iti)
3251         do k=1,2
3252           do l=1,2
3253            CC(k,l,i-2)=ccold(k,l,iti)
3254            DD(k,l,i-2)=ddold(k,l,iti)
3255            EE(k,l,i-2)=eeold(k,l,iti)
3256           enddo
3257         enddo
3258 #endif
3259         b1tilde(1,i-2)= b1(1,i-2)
3260         b1tilde(2,i-2)=-b1(2,i-2)
3261         b2tilde(1,i-2)= b2(1,i-2)
3262         b2tilde(2,i-2)=-b2(2,i-2)
3263 c
3264         Ctilde(1,1,i-2)= CC(1,1,i-2)
3265         Ctilde(1,2,i-2)= CC(1,2,i-2)
3266         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3267         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3268 c
3269         Dtilde(1,1,i-2)= DD(1,1,i-2)
3270         Dtilde(1,2,i-2)= DD(1,2,i-2)
3271         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3272         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3273 c        write(iout,*) "i",i," iti",iti
3274 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3275 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3276       enddo
3277       do i=3,nres+1
3278         if (i .lt. nres+1) then
3279           sin1=dsin(phi(i))
3280           cos1=dcos(phi(i))
3281           sintab(i-2)=sin1
3282           costab(i-2)=cos1
3283           obrot(1,i-2)=cos1
3284           obrot(2,i-2)=sin1
3285           sin2=dsin(2*phi(i))
3286           cos2=dcos(2*phi(i))
3287           sintab2(i-2)=sin2
3288           costab2(i-2)=cos2
3289           obrot2(1,i-2)=cos2
3290           obrot2(2,i-2)=sin2
3291           Ug(1,1,i-2)=-cos1
3292           Ug(1,2,i-2)=-sin1
3293           Ug(2,1,i-2)=-sin1
3294           Ug(2,2,i-2)= cos1
3295           Ug2(1,1,i-2)=-cos2
3296           Ug2(1,2,i-2)=-sin2
3297           Ug2(2,1,i-2)=-sin2
3298           Ug2(2,2,i-2)= cos2
3299         else
3300           costab(i-2)=1.0d0
3301           sintab(i-2)=0.0d0
3302           obrot(1,i-2)=1.0d0
3303           obrot(2,i-2)=0.0d0
3304           obrot2(1,i-2)=0.0d0
3305           obrot2(2,i-2)=0.0d0
3306           Ug(1,1,i-2)=1.0d0
3307           Ug(1,2,i-2)=0.0d0
3308           Ug(2,1,i-2)=0.0d0
3309           Ug(2,2,i-2)=1.0d0
3310           Ug2(1,1,i-2)=0.0d0
3311           Ug2(1,2,i-2)=0.0d0
3312           Ug2(2,1,i-2)=0.0d0
3313           Ug2(2,2,i-2)=0.0d0
3314         endif
3315         if (i .gt. 3 .and. i .lt. nres+1) then
3316           obrot_der(1,i-2)=-sin1
3317           obrot_der(2,i-2)= cos1
3318           Ugder(1,1,i-2)= sin1
3319           Ugder(1,2,i-2)=-cos1
3320           Ugder(2,1,i-2)=-cos1
3321           Ugder(2,2,i-2)=-sin1
3322           dwacos2=cos2+cos2
3323           dwasin2=sin2+sin2
3324           obrot2_der(1,i-2)=-dwasin2
3325           obrot2_der(2,i-2)= dwacos2
3326           Ug2der(1,1,i-2)= dwasin2
3327           Ug2der(1,2,i-2)=-dwacos2
3328           Ug2der(2,1,i-2)=-dwacos2
3329           Ug2der(2,2,i-2)=-dwasin2
3330         else
3331           obrot_der(1,i-2)=0.0d0
3332           obrot_der(2,i-2)=0.0d0
3333           Ugder(1,1,i-2)=0.0d0
3334           Ugder(1,2,i-2)=0.0d0
3335           Ugder(2,1,i-2)=0.0d0
3336           Ugder(2,2,i-2)=0.0d0
3337           obrot2_der(1,i-2)=0.0d0
3338           obrot2_der(2,i-2)=0.0d0
3339           Ug2der(1,1,i-2)=0.0d0
3340           Ug2der(1,2,i-2)=0.0d0
3341           Ug2der(2,1,i-2)=0.0d0
3342           Ug2der(2,2,i-2)=0.0d0
3343         endif
3344 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3345         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3346           iti = itype2loc(itype(i-2))
3347         else
3348           iti=nloctyp
3349         endif
3350 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3351         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3352           iti1 = itype2loc(itype(i-1))
3353         else
3354           iti1=nloctyp
3355         endif
3356 cd        write (iout,*) '*******i',i,' iti1',iti
3357 cd        write (iout,*) 'b1',b1(:,iti)
3358 cd        write (iout,*) 'b2',b2(:,iti)
3359 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3360 c        if (i .gt. iatel_s+2) then
3361         if (i .gt. nnt+2) then
3362           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3363 #ifdef NEWCORR
3364           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3365 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3366 #endif
3367 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3368 c     &    EE(1,2,iti),EE(2,2,i)
3369           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3370           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3371 c          write(iout,*) "Macierz EUG",
3372 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3373 c     &    eug(2,2,i-2)
3374           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3375      &    then
3376           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3377           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3378           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3379           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3380           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3381           endif
3382         else
3383           do k=1,2
3384             Ub2(k,i-2)=0.0d0
3385             Ctobr(k,i-2)=0.0d0
3386             Dtobr2(k,i-2)=0.0d0
3387             do l=1,2
3388               EUg(l,k,i-2)=0.0d0
3389               CUg(l,k,i-2)=0.0d0
3390               DUg(l,k,i-2)=0.0d0
3391               DtUg2(l,k,i-2)=0.0d0
3392             enddo
3393           enddo
3394         endif
3395         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3396         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3397         do k=1,2
3398           muder(k,i-2)=Ub2der(k,i-2)
3399         enddo
3400 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3401         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3402           if (itype(i-1).le.ntyp) then
3403             iti1 = itype2loc(itype(i-1))
3404           else
3405             iti1=nloctyp
3406           endif
3407         else
3408           iti1=nloctyp
3409         endif
3410         do k=1,2
3411           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3412         enddo
3413 #ifdef MUOUT
3414         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3415      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3416      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3417      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3418      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3419      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3420 #endif
3421 cd        write (iout,*) 'mu1',mu1(:,i-2)
3422 cd        write (iout,*) 'mu2',mu2(:,i-2)
3423         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3424      &  then
3425         if (calc_grad) then
3426         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3427         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3428         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3429         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3430         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3431         endif
3432 C Vectors and matrices dependent on a single virtual-bond dihedral.
3433         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3434         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3435         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3436         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3437         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3438         if (calc_grad) then
3439         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3440         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3441         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3442         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3443         endif
3444         endif
3445       enddo
3446 C Matrices dependent on two consecutive virtual-bond dihedrals.
3447 C The order of matrices is from left to right.
3448       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3449      &then
3450       do i=2,nres-1
3451         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3452         if (calc_grad) then
3453         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3454         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3455         endif
3456         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3457         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3458         if (calc_grad) then
3459         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3460         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3461         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3462         endif
3463       enddo
3464       endif
3465       return
3466       end
3467 C--------------------------------------------------------------------------
3468       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3469 C
3470 C This subroutine calculates the average interaction energy and its gradient
3471 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3472 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3473 C The potential depends both on the distance of peptide-group centers and on
3474 C the orientation of the CA-CA virtual bonds.
3475 C
3476       implicit real*8 (a-h,o-z)
3477 #ifdef MPI
3478       include 'mpif.h'
3479 #endif
3480       include 'DIMENSIONS'
3481       include 'DIMENSIONS.ZSCOPT'
3482       include 'COMMON.CONTROL'
3483       include 'COMMON.IOUNITS'
3484       include 'COMMON.GEO'
3485       include 'COMMON.VAR'
3486       include 'COMMON.LOCAL'
3487       include 'COMMON.CHAIN'
3488       include 'COMMON.DERIV'
3489       include 'COMMON.INTERACT'
3490       include 'COMMON.CONTACTS'
3491       include 'COMMON.TORSION'
3492       include 'COMMON.VECTORS'
3493       include 'COMMON.FFIELD'
3494       include 'COMMON.TIME1'
3495       include 'COMMON.SPLITELE'
3496       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3497      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3498       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3499      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3500       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3501      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3502      &    num_conti,j1,j2
3503 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3504 #ifdef MOMENT
3505       double precision scal_el /1.0d0/
3506 #else
3507       double precision scal_el /0.5d0/
3508 #endif
3509 C 12/13/98
3510 C 13-go grudnia roku pamietnego...
3511       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3512      &                   0.0d0,1.0d0,0.0d0,
3513      &                   0.0d0,0.0d0,1.0d0/
3514 cd      write(iout,*) 'In EELEC'
3515 cd      do i=1,nloctyp
3516 cd        write(iout,*) 'Type',i
3517 cd        write(iout,*) 'B1',B1(:,i)
3518 cd        write(iout,*) 'B2',B2(:,i)
3519 cd        write(iout,*) 'CC',CC(:,:,i)
3520 cd        write(iout,*) 'DD',DD(:,:,i)
3521 cd        write(iout,*) 'EE',EE(:,:,i)
3522 cd      enddo
3523 cd      call check_vecgrad
3524 cd      stop
3525       if (icheckgrad.eq.1) then
3526         do i=1,nres-1
3527           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3528           do k=1,3
3529             dc_norm(k,i)=dc(k,i)*fac
3530           enddo
3531 c          write (iout,*) 'i',i,' fac',fac
3532         enddo
3533       endif
3534       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3535      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3536      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3537 c        call vec_and_deriv
3538 #ifdef TIMING
3539         time01=MPI_Wtime()
3540 #endif
3541         call set_matrices
3542 #ifdef TIMING
3543         time_mat=time_mat+MPI_Wtime()-time01
3544 #endif
3545       endif
3546 cd      do i=1,nres-1
3547 cd        write (iout,*) 'i=',i
3548 cd        do k=1,3
3549 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3550 cd        enddo
3551 cd        do k=1,3
3552 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3553 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3554 cd        enddo
3555 cd      enddo
3556       t_eelecij=0.0d0
3557       ees=0.0D0
3558       evdw1=0.0D0
3559       eel_loc=0.0d0
3560       eello_turn3=0.0d0
3561       eello_turn4=0.0d0
3562       ind=0
3563       do i=1,nres
3564         num_cont_hb(i)=0
3565       enddo
3566 cd      print '(a)','Enter EELEC'
3567 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3568       do i=1,nres
3569         gel_loc_loc(i)=0.0d0
3570         gcorr_loc(i)=0.0d0
3571       enddo
3572 c
3573 c
3574 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3575 C
3576 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3577 C
3578 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3579       do i=iturn3_start,iturn3_end
3580 c        if (i.le.1) cycle
3581 C        write(iout,*) "tu jest i",i
3582         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3583 C changes suggested by Ana to avoid out of bounds
3584 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3585 c     & .or.((i+4).gt.nres)
3586 c     & .or.((i-1).le.0)
3587 C end of changes by Ana
3588 C dobra zmiana wycofana
3589      &  .or. itype(i+2).eq.ntyp1
3590      &  .or. itype(i+3).eq.ntyp1) cycle
3591 C Adam: Instructions below will switch off existing interactions
3592 c        if(i.gt.1)then
3593 c          if(itype(i-1).eq.ntyp1)cycle
3594 c        end if
3595 c        if(i.LT.nres-3)then
3596 c          if (itype(i+4).eq.ntyp1) cycle
3597 c        end if
3598         dxi=dc(1,i)
3599         dyi=dc(2,i)
3600         dzi=dc(3,i)
3601         dx_normi=dc_norm(1,i)
3602         dy_normi=dc_norm(2,i)
3603         dz_normi=dc_norm(3,i)
3604         xmedi=c(1,i)+0.5d0*dxi
3605         ymedi=c(2,i)+0.5d0*dyi
3606         zmedi=c(3,i)+0.5d0*dzi
3607           xmedi=mod(xmedi,boxxsize)
3608           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3609           ymedi=mod(ymedi,boxysize)
3610           if (ymedi.lt.0) ymedi=ymedi+boxysize
3611           zmedi=mod(zmedi,boxzsize)
3612           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3613         num_conti=0
3614         call eelecij(i,i+2,ees,evdw1,eel_loc)
3615         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3616         num_cont_hb(i)=num_conti
3617       enddo
3618       do i=iturn4_start,iturn4_end
3619         if (i.lt.1) cycle
3620         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3621 C changes suggested by Ana to avoid out of bounds
3622 c     & .or.((i+5).gt.nres)
3623 c     & .or.((i-1).le.0)
3624 C end of changes suggested by Ana
3625      &    .or. itype(i+3).eq.ntyp1
3626      &    .or. itype(i+4).eq.ntyp1
3627 c     &    .or. itype(i+5).eq.ntyp1
3628 c     &    .or. itype(i).eq.ntyp1
3629 c     &    .or. itype(i-1).eq.ntyp1
3630      &                             ) cycle
3631         dxi=dc(1,i)
3632         dyi=dc(2,i)
3633         dzi=dc(3,i)
3634         dx_normi=dc_norm(1,i)
3635         dy_normi=dc_norm(2,i)
3636         dz_normi=dc_norm(3,i)
3637         xmedi=c(1,i)+0.5d0*dxi
3638         ymedi=c(2,i)+0.5d0*dyi
3639         zmedi=c(3,i)+0.5d0*dzi
3640 C Return atom into box, boxxsize is size of box in x dimension
3641 c  194   continue
3642 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3643 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3644 C Condition for being inside the proper box
3645 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3646 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3647 c        go to 194
3648 c        endif
3649 c  195   continue
3650 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3651 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3652 C Condition for being inside the proper box
3653 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3654 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3655 c        go to 195
3656 c        endif
3657 c  196   continue
3658 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3659 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3660 C Condition for being inside the proper box
3661 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3662 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3663 c        go to 196
3664 c        endif
3665           xmedi=mod(xmedi,boxxsize)
3666           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3667           ymedi=mod(ymedi,boxysize)
3668           if (ymedi.lt.0) ymedi=ymedi+boxysize
3669           zmedi=mod(zmedi,boxzsize)
3670           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3671
3672         num_conti=num_cont_hb(i)
3673 c        write(iout,*) "JESTEM W PETLI"
3674         call eelecij(i,i+3,ees,evdw1,eel_loc)
3675         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3676      &   call eturn4(i,eello_turn4)
3677         num_cont_hb(i)=num_conti
3678       enddo   ! i
3679 C Loop over all neighbouring boxes
3680 C      do xshift=-1,1
3681 C      do yshift=-1,1
3682 C      do zshift=-1,1
3683 c
3684 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3685 c
3686 CTU KURWA
3687       do i=iatel_s,iatel_e
3688 C        do i=75,75
3689 c        if (i.le.1) cycle
3690         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3691 C changes suggested by Ana to avoid out of bounds
3692 c     & .or.((i+2).gt.nres)
3693 c     & .or.((i-1).le.0)
3694 C end of changes by Ana
3695 c     &  .or. itype(i+2).eq.ntyp1
3696 c     &  .or. itype(i-1).eq.ntyp1
3697      &                ) cycle
3698         dxi=dc(1,i)
3699         dyi=dc(2,i)
3700         dzi=dc(3,i)
3701         dx_normi=dc_norm(1,i)
3702         dy_normi=dc_norm(2,i)
3703         dz_normi=dc_norm(3,i)
3704         xmedi=c(1,i)+0.5d0*dxi
3705         ymedi=c(2,i)+0.5d0*dyi
3706         zmedi=c(3,i)+0.5d0*dzi
3707           xmedi=mod(xmedi,boxxsize)
3708           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3709           ymedi=mod(ymedi,boxysize)
3710           if (ymedi.lt.0) ymedi=ymedi+boxysize
3711           zmedi=mod(zmedi,boxzsize)
3712           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3713 C          xmedi=xmedi+xshift*boxxsize
3714 C          ymedi=ymedi+yshift*boxysize
3715 C          zmedi=zmedi+zshift*boxzsize
3716
3717 C Return tom into box, boxxsize is size of box in x dimension
3718 c  164   continue
3719 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3720 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3721 C Condition for being inside the proper box
3722 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3723 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3724 c        go to 164
3725 c        endif
3726 c  165   continue
3727 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3728 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3729 C Condition for being inside the proper box
3730 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3731 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3732 c        go to 165
3733 c        endif
3734 c  166   continue
3735 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3736 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3737 cC Condition for being inside the proper box
3738 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3739 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3740 c        go to 166
3741 c        endif
3742
3743 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3744         num_conti=num_cont_hb(i)
3745 C I TU KURWA
3746         do j=ielstart(i),ielend(i)
3747 C          do j=16,17
3748 C          write (iout,*) i,j
3749 C         if (j.le.1) cycle
3750           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3751 C changes suggested by Ana to avoid out of bounds
3752 c     & .or.((j+2).gt.nres)
3753 c     & .or.((j-1).le.0)
3754 C end of changes by Ana
3755 c     & .or.itype(j+2).eq.ntyp1
3756 c     & .or.itype(j-1).eq.ntyp1
3757      &) cycle
3758           call eelecij(i,j,ees,evdw1,eel_loc)
3759         enddo ! j
3760         num_cont_hb(i)=num_conti
3761       enddo   ! i
3762 C     enddo   ! zshift
3763 C      enddo   ! yshift
3764 C      enddo   ! xshift
3765
3766 c      write (iout,*) "Number of loop steps in EELEC:",ind
3767 cd      do i=1,nres
3768 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3769 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3770 cd      enddo
3771 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3772 ccc      eel_loc=eel_loc+eello_turn3
3773 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3774       return
3775       end
3776 C-------------------------------------------------------------------------------
3777       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3778       implicit real*8 (a-h,o-z)
3779       include 'DIMENSIONS'
3780       include 'DIMENSIONS.ZSCOPT'
3781 #ifdef MPI
3782       include "mpif.h"
3783 #endif
3784       include 'COMMON.CONTROL'
3785       include 'COMMON.IOUNITS'
3786       include 'COMMON.GEO'
3787       include 'COMMON.VAR'
3788       include 'COMMON.LOCAL'
3789       include 'COMMON.CHAIN'
3790       include 'COMMON.DERIV'
3791       include 'COMMON.INTERACT'
3792       include 'COMMON.CONTACTS'
3793       include 'COMMON.TORSION'
3794       include 'COMMON.VECTORS'
3795       include 'COMMON.FFIELD'
3796       include 'COMMON.TIME1'
3797       include 'COMMON.SPLITELE'
3798       include 'COMMON.SHIELD'
3799       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3800      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3801       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3802      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3803      &    gmuij2(4),gmuji2(4)
3804       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3805      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3806      &    num_conti,j1,j2
3807 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3808 #ifdef MOMENT
3809       double precision scal_el /1.0d0/
3810 #else
3811       double precision scal_el /0.5d0/
3812 #endif
3813 C 12/13/98
3814 C 13-go grudnia roku pamietnego...
3815       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3816      &                   0.0d0,1.0d0,0.0d0,
3817      &                   0.0d0,0.0d0,1.0d0/
3818        integer xshift,yshift,zshift
3819 c          time00=MPI_Wtime()
3820 cd      write (iout,*) "eelecij",i,j
3821 c          ind=ind+1
3822           iteli=itel(i)
3823           itelj=itel(j)
3824           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3825           aaa=app(iteli,itelj)
3826           bbb=bpp(iteli,itelj)
3827           ael6i=ael6(iteli,itelj)
3828           ael3i=ael3(iteli,itelj)
3829           dxj=dc(1,j)
3830           dyj=dc(2,j)
3831           dzj=dc(3,j)
3832           dx_normj=dc_norm(1,j)
3833           dy_normj=dc_norm(2,j)
3834           dz_normj=dc_norm(3,j)
3835 C          xj=c(1,j)+0.5D0*dxj-xmedi
3836 C          yj=c(2,j)+0.5D0*dyj-ymedi
3837 C          zj=c(3,j)+0.5D0*dzj-zmedi
3838           xj=c(1,j)+0.5D0*dxj
3839           yj=c(2,j)+0.5D0*dyj
3840           zj=c(3,j)+0.5D0*dzj
3841           xj=mod(xj,boxxsize)
3842           if (xj.lt.0) xj=xj+boxxsize
3843           yj=mod(yj,boxysize)
3844           if (yj.lt.0) yj=yj+boxysize
3845           zj=mod(zj,boxzsize)
3846           if (zj.lt.0) zj=zj+boxzsize
3847           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3848       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3849       xj_safe=xj
3850       yj_safe=yj
3851       zj_safe=zj
3852       isubchap=0
3853       do xshift=-1,1
3854       do yshift=-1,1
3855       do zshift=-1,1
3856           xj=xj_safe+xshift*boxxsize
3857           yj=yj_safe+yshift*boxysize
3858           zj=zj_safe+zshift*boxzsize
3859           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3860           if(dist_temp.lt.dist_init) then
3861             dist_init=dist_temp
3862             xj_temp=xj
3863             yj_temp=yj
3864             zj_temp=zj
3865             isubchap=1
3866           endif
3867        enddo
3868        enddo
3869        enddo
3870        if (isubchap.eq.1) then
3871           xj=xj_temp-xmedi
3872           yj=yj_temp-ymedi
3873           zj=zj_temp-zmedi
3874        else
3875           xj=xj_safe-xmedi
3876           yj=yj_safe-ymedi
3877           zj=zj_safe-zmedi
3878        endif
3879 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3880 c  174   continue
3881 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3882 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3883 C Condition for being inside the proper box
3884 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3885 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3886 c        go to 174
3887 c        endif
3888 c  175   continue
3889 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3890 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3891 C Condition for being inside the proper box
3892 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3893 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3894 c        go to 175
3895 c        endif
3896 c  176   continue
3897 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3898 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3899 C Condition for being inside the proper box
3900 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3901 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3902 c        go to 176
3903 c        endif
3904 C        endif !endPBC condintion
3905 C        xj=xj-xmedi
3906 C        yj=yj-ymedi
3907 C        zj=zj-zmedi
3908           rij=xj*xj+yj*yj+zj*zj
3909
3910             sss=sscale(sqrt(rij))
3911             sssgrad=sscagrad(sqrt(rij))
3912 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
3913 c     &       " rlamb",rlamb," sss",sss
3914 c            if (sss.gt.0.0d0) then
3915           rrmij=1.0D0/rij
3916           rij=dsqrt(rij)
3917           rmij=1.0D0/rij
3918           r3ij=rrmij*rmij
3919           r6ij=r3ij*r3ij
3920           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3921           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3922           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3923           fac=cosa-3.0D0*cosb*cosg
3924           ev1=aaa*r6ij*r6ij
3925 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3926           if (j.eq.i+2) ev1=scal_el*ev1
3927           ev2=bbb*r6ij
3928           fac3=ael6i*r6ij
3929           fac4=ael3i*r3ij
3930           evdwij=(ev1+ev2)
3931           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3932           el2=fac4*fac
3933 C MARYSIA
3934 C          eesij=(el1+el2)
3935 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3936           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3937           if (shield_mode.gt.0) then
3938 C          fac_shield(i)=0.4
3939 C          fac_shield(j)=0.6
3940           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3941           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3942           eesij=(el1+el2)
3943           ees=ees+eesij
3944           else
3945           fac_shield(i)=1.0
3946           fac_shield(j)=1.0
3947           eesij=(el1+el2)
3948           ees=ees+eesij
3949           endif
3950           evdw1=evdw1+evdwij*sss
3951 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3952 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3953 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3954 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3955
3956           if (energy_dec) then
3957               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
3958      &'evdw1',i,j,evdwij
3959      &,iteli,itelj,aaa,evdw1,sss
3960               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3961      &fac_shield(i),fac_shield(j)
3962           endif
3963
3964 C
3965 C Calculate contributions to the Cartesian gradient.
3966 C
3967 #ifdef SPLITELE
3968           facvdw=-6*rrmij*(ev1+evdwij)*sss
3969           facel=-3*rrmij*(el1+eesij)
3970           fac1=fac
3971           erij(1)=xj*rmij
3972           erij(2)=yj*rmij
3973           erij(3)=zj*rmij
3974
3975 *
3976 * Radial derivatives. First process both termini of the fragment (i,j)
3977 *
3978           if (calc_grad) then
3979           ggg(1)=facel*xj
3980           ggg(2)=facel*yj
3981           ggg(3)=facel*zj
3982           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3983      &  (shield_mode.gt.0)) then
3984 C          print *,i,j
3985           do ilist=1,ishield_list(i)
3986            iresshield=shield_list(ilist,i)
3987            do k=1,3
3988            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3989      &      *2.0
3990            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3991      &              rlocshield
3992      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3993             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3994 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3995 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3996 C             if (iresshield.gt.i) then
3997 C               do ishi=i+1,iresshield-1
3998 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3999 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4000 C
4001 C              enddo
4002 C             else
4003 C               do ishi=iresshield,i
4004 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4005 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4006 C
4007 C               enddo
4008 C              endif
4009            enddo
4010           enddo
4011           do ilist=1,ishield_list(j)
4012            iresshield=shield_list(ilist,j)
4013            do k=1,3
4014            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4015      &     *2.0
4016            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4017      &              rlocshield
4018      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4019            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4020
4021 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4022 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4023 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4024 C             if (iresshield.gt.j) then
4025 C               do ishi=j+1,iresshield-1
4026 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4027 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4028 C
4029 C               enddo
4030 C            else
4031 C               do ishi=iresshield,j
4032 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4033 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4034 C               enddo
4035 C              endif
4036            enddo
4037           enddo
4038
4039           do k=1,3
4040             gshieldc(k,i)=gshieldc(k,i)+
4041      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4042             gshieldc(k,j)=gshieldc(k,j)+
4043      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4044             gshieldc(k,i-1)=gshieldc(k,i-1)+
4045      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4046             gshieldc(k,j-1)=gshieldc(k,j-1)+
4047      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4048
4049            enddo
4050            endif
4051 c          do k=1,3
4052 c            ghalf=0.5D0*ggg(k)
4053 c            gelc(k,i)=gelc(k,i)+ghalf
4054 c            gelc(k,j)=gelc(k,j)+ghalf
4055 c          enddo
4056 c 9/28/08 AL Gradient compotents will be summed only at the end
4057 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4058           do k=1,3
4059             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4060 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4061             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4062 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4063 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4064 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4065 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4066 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4067           enddo
4068 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4069
4070 *
4071 * Loop over residues i+1 thru j-1.
4072 *
4073 cgrad          do k=i+1,j-1
4074 cgrad            do l=1,3
4075 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4076 cgrad            enddo
4077 cgrad          enddo
4078           if (sss.gt.0.0) then
4079           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4080           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4081           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4082           else
4083           ggg(1)=0.0
4084           ggg(2)=0.0
4085           ggg(3)=0.0
4086           endif
4087 c          do k=1,3
4088 c            ghalf=0.5D0*ggg(k)
4089 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4090 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4091 c          enddo
4092 c 9/28/08 AL Gradient compotents will be summed only at the end
4093           do k=1,3
4094             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4095             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4096           enddo
4097 *
4098 * Loop over residues i+1 thru j-1.
4099 *
4100 cgrad          do k=i+1,j-1
4101 cgrad            do l=1,3
4102 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4103 cgrad            enddo
4104 cgrad          enddo
4105           endif ! calc_grad
4106 #else
4107 C MARYSIA
4108           facvdw=(ev1+evdwij)*sss
4109           facel=(el1+eesij)
4110           fac1=fac
4111           fac=-3*rrmij*(facvdw+facvdw+facel)
4112           erij(1)=xj*rmij
4113           erij(2)=yj*rmij
4114           erij(3)=zj*rmij
4115 *
4116 * Radial derivatives. First process both termini of the fragment (i,j)
4117 *
4118           if (calc_grad) then
4119           ggg(1)=fac*xj
4120 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4121           ggg(2)=fac*yj
4122 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4123           ggg(3)=fac*zj
4124 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4125 c          do k=1,3
4126 c            ghalf=0.5D0*ggg(k)
4127 c            gelc(k,i)=gelc(k,i)+ghalf
4128 c            gelc(k,j)=gelc(k,j)+ghalf
4129 c          enddo
4130 c 9/28/08 AL Gradient compotents will be summed only at the end
4131           do k=1,3
4132             gelc_long(k,j)=gelc(k,j)+ggg(k)
4133             gelc_long(k,i)=gelc(k,i)-ggg(k)
4134           enddo
4135 *
4136 * Loop over residues i+1 thru j-1.
4137 *
4138 cgrad          do k=i+1,j-1
4139 cgrad            do l=1,3
4140 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4141 cgrad            enddo
4142 cgrad          enddo
4143 c 9/28/08 AL Gradient compotents will be summed only at the end
4144           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4145           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4146           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4147           do k=1,3
4148             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4149             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4150           enddo
4151           endif ! calc_grad
4152 #endif
4153 *
4154 * Angular part
4155 *
4156           if (calc_grad) then
4157           ecosa=2.0D0*fac3*fac1+fac4
4158           fac4=-3.0D0*fac4
4159           fac3=-6.0D0*fac3
4160           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4161           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4162           do k=1,3
4163             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4164             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4165           enddo
4166 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4167 cd   &          (dcosg(k),k=1,3)
4168           do k=1,3
4169             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4170      &      fac_shield(i)**2*fac_shield(j)**2
4171           enddo
4172 c          do k=1,3
4173 c            ghalf=0.5D0*ggg(k)
4174 c            gelc(k,i)=gelc(k,i)+ghalf
4175 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4176 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4177 c            gelc(k,j)=gelc(k,j)+ghalf
4178 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4179 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4180 c          enddo
4181 cgrad          do k=i+1,j-1
4182 cgrad            do l=1,3
4183 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4184 cgrad            enddo
4185 cgrad          enddo
4186 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4187           do k=1,3
4188             gelc(k,i)=gelc(k,i)
4189      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4190      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4191      &           *fac_shield(i)**2*fac_shield(j)**2
4192             gelc(k,j)=gelc(k,j)
4193      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4194      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4195      &           *fac_shield(i)**2*fac_shield(j)**2
4196             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4197             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4198           enddo
4199 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4200
4201 C MARYSIA
4202 c          endif !sscale
4203           endif ! calc_grad
4204           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4205      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4206      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4207 C
4208 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4209 C   energy of a peptide unit is assumed in the form of a second-order
4210 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4211 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4212 C   are computed for EVERY pair of non-contiguous peptide groups.
4213 C
4214
4215           if (j.lt.nres-1) then
4216             j1=j+1
4217             j2=j-1
4218           else
4219             j1=j-1
4220             j2=j-2
4221           endif
4222           kkk=0
4223           lll=0
4224           do k=1,2
4225             do l=1,2
4226               kkk=kkk+1
4227               muij(kkk)=mu(k,i)*mu(l,j)
4228 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4229 #ifdef NEWCORR
4230              if (calc_grad) then
4231              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4232 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4233              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4234              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4235 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4236              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4237              endif
4238 #endif
4239             enddo
4240           enddo
4241 #ifdef DEBUG
4242           write (iout,*) 'EELEC: i',i,' j',j
4243           write (iout,*) 'j',j,' j1',j1,' j2',j2
4244           write(iout,*) 'muij',muij
4245           write (iout,*) "uy",uy(:,i)
4246           write (iout,*) "uz",uz(:,j)
4247           write (iout,*) "erij",erij
4248 #endif
4249           ury=scalar(uy(1,i),erij)
4250           urz=scalar(uz(1,i),erij)
4251           vry=scalar(uy(1,j),erij)
4252           vrz=scalar(uz(1,j),erij)
4253           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4254           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4255           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4256           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4257           fac=dsqrt(-ael6i)*r3ij
4258           a22=a22*fac
4259           a23=a23*fac
4260           a32=a32*fac
4261           a33=a33*fac
4262 cd          write (iout,'(4i5,4f10.5)')
4263 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4264 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4265 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4266 cd     &      uy(:,j),uz(:,j)
4267 cd          write (iout,'(4f10.5)')
4268 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4269 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4270 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4271 cd           write (iout,'(9f10.5/)')
4272 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4273 C Derivatives of the elements of A in virtual-bond vectors
4274           if (calc_grad) then
4275           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4276           do k=1,3
4277             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4278             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4279             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4280             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4281             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4282             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4283             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4284             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4285             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4286             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4287             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4288             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4289           enddo
4290 C Compute radial contributions to the gradient
4291           facr=-3.0d0*rrmij
4292           a22der=a22*facr
4293           a23der=a23*facr
4294           a32der=a32*facr
4295           a33der=a33*facr
4296           agg(1,1)=a22der*xj
4297           agg(2,1)=a22der*yj
4298           agg(3,1)=a22der*zj
4299           agg(1,2)=a23der*xj
4300           agg(2,2)=a23der*yj
4301           agg(3,2)=a23der*zj
4302           agg(1,3)=a32der*xj
4303           agg(2,3)=a32der*yj
4304           agg(3,3)=a32der*zj
4305           agg(1,4)=a33der*xj
4306           agg(2,4)=a33der*yj
4307           agg(3,4)=a33der*zj
4308 C Add the contributions coming from er
4309           fac3=-3.0d0*fac
4310           do k=1,3
4311             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4312             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4313             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4314             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4315           enddo
4316           do k=1,3
4317 C Derivatives in DC(i)
4318 cgrad            ghalf1=0.5d0*agg(k,1)
4319 cgrad            ghalf2=0.5d0*agg(k,2)
4320 cgrad            ghalf3=0.5d0*agg(k,3)
4321 cgrad            ghalf4=0.5d0*agg(k,4)
4322             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4323      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4324             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4325      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4326             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4327      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4328             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4329      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4330 C Derivatives in DC(i+1)
4331             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4332      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4333             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4334      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4335             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4336      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4337             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4338      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4339 C Derivatives in DC(j)
4340             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4341      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4342             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4343      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4344             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4345      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4346             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4347      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4348 C Derivatives in DC(j+1) or DC(nres-1)
4349             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4350      &      -3.0d0*vryg(k,3)*ury)
4351             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4352      &      -3.0d0*vrzg(k,3)*ury)
4353             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4354      &      -3.0d0*vryg(k,3)*urz)
4355             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4356      &      -3.0d0*vrzg(k,3)*urz)
4357 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4358 cgrad              do l=1,4
4359 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4360 cgrad              enddo
4361 cgrad            endif
4362           enddo
4363           endif ! calc_grad
4364           acipa(1,1)=a22
4365           acipa(1,2)=a23
4366           acipa(2,1)=a32
4367           acipa(2,2)=a33
4368           a22=-a22
4369           a23=-a23
4370           if (calc_grad) then
4371           do l=1,2
4372             do k=1,3
4373               agg(k,l)=-agg(k,l)
4374               aggi(k,l)=-aggi(k,l)
4375               aggi1(k,l)=-aggi1(k,l)
4376               aggj(k,l)=-aggj(k,l)
4377               aggj1(k,l)=-aggj1(k,l)
4378             enddo
4379           enddo
4380           endif ! calc_grad
4381           if (j.lt.nres-1) then
4382             a22=-a22
4383             a32=-a32
4384             do l=1,3,2
4385               do k=1,3
4386                 agg(k,l)=-agg(k,l)
4387                 aggi(k,l)=-aggi(k,l)
4388                 aggi1(k,l)=-aggi1(k,l)
4389                 aggj(k,l)=-aggj(k,l)
4390                 aggj1(k,l)=-aggj1(k,l)
4391               enddo
4392             enddo
4393           else
4394             a22=-a22
4395             a23=-a23
4396             a32=-a32
4397             a33=-a33
4398             do l=1,4
4399               do k=1,3
4400                 agg(k,l)=-agg(k,l)
4401                 aggi(k,l)=-aggi(k,l)
4402                 aggi1(k,l)=-aggi1(k,l)
4403                 aggj(k,l)=-aggj(k,l)
4404                 aggj1(k,l)=-aggj1(k,l)
4405               enddo
4406             enddo
4407           endif
4408           ENDIF ! WCORR
4409           IF (wel_loc.gt.0.0d0) THEN
4410 C Contribution to the local-electrostatic energy coming from the i-j pair
4411           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4412      &     +a33*muij(4)
4413 #ifdef DEBUG
4414           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4415      &     " a33",a33
4416           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4417      &     " wel_loc",wel_loc
4418 #endif
4419           if (shield_mode.eq.0) then
4420            fac_shield(i)=1.0
4421            fac_shield(j)=1.0
4422 C          else
4423 C           fac_shield(i)=0.4
4424 C           fac_shield(j)=0.6
4425           endif
4426           eel_loc_ij=eel_loc_ij
4427      &    *fac_shield(i)*fac_shield(j)
4428           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4429      &            'eelloc',i,j,eel_loc_ij
4430 c           if (eel_loc_ij.ne.0)
4431 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4432 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4433
4434           eel_loc=eel_loc+eel_loc_ij
4435 C Now derivative over eel_loc
4436           if (calc_grad) then
4437           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4438      &  (shield_mode.gt.0)) then
4439 C          print *,i,j
4440
4441           do ilist=1,ishield_list(i)
4442            iresshield=shield_list(ilist,i)
4443            do k=1,3
4444            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4445      &                                          /fac_shield(i)
4446 C     &      *2.0
4447            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4448      &              rlocshield
4449      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4450             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4451      &      +rlocshield
4452            enddo
4453           enddo
4454           do ilist=1,ishield_list(j)
4455            iresshield=shield_list(ilist,j)
4456            do k=1,3
4457            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4458      &                                       /fac_shield(j)
4459 C     &     *2.0
4460            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4461      &              rlocshield
4462      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4463            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4464      &             +rlocshield
4465
4466            enddo
4467           enddo
4468
4469           do k=1,3
4470             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4471      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4472             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4473      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4474             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4475      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4476             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4477      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4478            enddo
4479            endif
4480
4481
4482 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4483 c     &                     ' eel_loc_ij',eel_loc_ij
4484 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4485 C Calculate patrial derivative for theta angle
4486 #ifdef NEWCORR
4487          geel_loc_ij=(a22*gmuij1(1)
4488      &     +a23*gmuij1(2)
4489      &     +a32*gmuij1(3)
4490      &     +a33*gmuij1(4))
4491      &    *fac_shield(i)*fac_shield(j)
4492 c         write(iout,*) "derivative over thatai"
4493 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4494 c     &   a33*gmuij1(4)
4495          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4496      &      geel_loc_ij*wel_loc
4497 c         write(iout,*) "derivative over thatai-1"
4498 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4499 c     &   a33*gmuij2(4)
4500          geel_loc_ij=
4501      &     a22*gmuij2(1)
4502      &     +a23*gmuij2(2)
4503      &     +a32*gmuij2(3)
4504      &     +a33*gmuij2(4)
4505          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4506      &      geel_loc_ij*wel_loc
4507      &    *fac_shield(i)*fac_shield(j)
4508
4509 c  Derivative over j residue
4510          geel_loc_ji=a22*gmuji1(1)
4511      &     +a23*gmuji1(2)
4512      &     +a32*gmuji1(3)
4513      &     +a33*gmuji1(4)
4514 c         write(iout,*) "derivative over thataj"
4515 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4516 c     &   a33*gmuji1(4)
4517
4518         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4519      &      geel_loc_ji*wel_loc
4520      &    *fac_shield(i)*fac_shield(j)
4521
4522          geel_loc_ji=
4523      &     +a22*gmuji2(1)
4524      &     +a23*gmuji2(2)
4525      &     +a32*gmuji2(3)
4526      &     +a33*gmuji2(4)
4527 c         write(iout,*) "derivative over thataj-1"
4528 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4529 c     &   a33*gmuji2(4)
4530          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4531      &      geel_loc_ji*wel_loc
4532      &    *fac_shield(i)*fac_shield(j)
4533 #endif
4534 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4535
4536 C Partial derivatives in virtual-bond dihedral angles gamma
4537           if (i.gt.1)
4538      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4539      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4540      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4541      &    *fac_shield(i)*fac_shield(j)
4542
4543           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4544      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4545      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4546      &    *fac_shield(i)*fac_shield(j)
4547 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4548           do l=1,3
4549             ggg(l)=(agg(l,1)*muij(1)+
4550      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4551      &    *fac_shield(i)*fac_shield(j)
4552             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4553             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4554 cgrad            ghalf=0.5d0*ggg(l)
4555 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4556 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4557           enddo
4558 cgrad          do k=i+1,j2
4559 cgrad            do l=1,3
4560 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4561 cgrad            enddo
4562 cgrad          enddo
4563 C Remaining derivatives of eello
4564           do l=1,3
4565             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4566      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4567      &    *fac_shield(i)*fac_shield(j)
4568
4569             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4570      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4571      &    *fac_shield(i)*fac_shield(j)
4572
4573             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4574      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4575      &    *fac_shield(i)*fac_shield(j)
4576
4577             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4578      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4579      &    *fac_shield(i)*fac_shield(j)
4580
4581           enddo
4582           endif ! calc_grad
4583           ENDIF
4584
4585
4586 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4587 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4588           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4589      &       .and. num_conti.le.maxconts) then
4590 c            write (iout,*) i,j," entered corr"
4591 C
4592 C Calculate the contact function. The ith column of the array JCONT will
4593 C contain the numbers of atoms that make contacts with the atom I (of numbers
4594 C greater than I). The arrays FACONT and GACONT will contain the values of
4595 C the contact function and its derivative.
4596 c           r0ij=1.02D0*rpp(iteli,itelj)
4597 c           r0ij=1.11D0*rpp(iteli,itelj)
4598             r0ij=2.20D0*rpp(iteli,itelj)
4599 c           r0ij=1.55D0*rpp(iteli,itelj)
4600             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4601             if (fcont.gt.0.0D0) then
4602               num_conti=num_conti+1
4603               if (num_conti.gt.maxconts) then
4604                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4605      &                         ' will skip next contacts for this conf.'
4606               else
4607                 jcont_hb(num_conti,i)=j
4608 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4609 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4610                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4611      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4612 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4613 C  terms.
4614                 d_cont(num_conti,i)=rij
4615 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4616 C     --- Electrostatic-interaction matrix ---
4617                 a_chuj(1,1,num_conti,i)=a22
4618                 a_chuj(1,2,num_conti,i)=a23
4619                 a_chuj(2,1,num_conti,i)=a32
4620                 a_chuj(2,2,num_conti,i)=a33
4621 C     --- Gradient of rij
4622                 if (calc_grad) then
4623                 do kkk=1,3
4624                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4625                 enddo
4626                 kkll=0
4627                 do k=1,2
4628                   do l=1,2
4629                     kkll=kkll+1
4630                     do m=1,3
4631                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4632                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4633                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4634                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4635                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4636                     enddo
4637                   enddo
4638                 enddo
4639                 endif ! calc_grad
4640                 ENDIF
4641                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4642 C Calculate contact energies
4643                 cosa4=4.0D0*cosa
4644                 wij=cosa-3.0D0*cosb*cosg
4645                 cosbg1=cosb+cosg
4646                 cosbg2=cosb-cosg
4647 c               fac3=dsqrt(-ael6i)/r0ij**3
4648                 fac3=dsqrt(-ael6i)*r3ij
4649 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4650                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4651                 if (ees0tmp.gt.0) then
4652                   ees0pij=dsqrt(ees0tmp)
4653                 else
4654                   ees0pij=0
4655                 endif
4656 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4657                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4658                 if (ees0tmp.gt.0) then
4659                   ees0mij=dsqrt(ees0tmp)
4660                 else
4661                   ees0mij=0
4662                 endif
4663 c               ees0mij=0.0D0
4664                 if (shield_mode.eq.0) then
4665                 fac_shield(i)=1.0d0
4666                 fac_shield(j)=1.0d0
4667                 else
4668                 ees0plist(num_conti,i)=j
4669 C                fac_shield(i)=0.4d0
4670 C                fac_shield(j)=0.6d0
4671                 endif
4672                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4673      &          *fac_shield(i)*fac_shield(j)
4674                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4675      &          *fac_shield(i)*fac_shield(j)
4676 C Diagnostics. Comment out or remove after debugging!
4677 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4678 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4679 c               ees0m(num_conti,i)=0.0D0
4680 C End diagnostics.
4681 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4682 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4683 C Angular derivatives of the contact function
4684
4685                 ees0pij1=fac3/ees0pij
4686                 ees0mij1=fac3/ees0mij
4687                 fac3p=-3.0D0*fac3*rrmij
4688                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4689                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4690 c               ees0mij1=0.0D0
4691                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4692                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4693                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4694                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4695                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4696                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4697                 ecosap=ecosa1+ecosa2
4698                 ecosbp=ecosb1+ecosb2
4699                 ecosgp=ecosg1+ecosg2
4700                 ecosam=ecosa1-ecosa2
4701                 ecosbm=ecosb1-ecosb2
4702                 ecosgm=ecosg1-ecosg2
4703 C Diagnostics
4704 c               ecosap=ecosa1
4705 c               ecosbp=ecosb1
4706 c               ecosgp=ecosg1
4707 c               ecosam=0.0D0
4708 c               ecosbm=0.0D0
4709 c               ecosgm=0.0D0
4710 C End diagnostics
4711                 facont_hb(num_conti,i)=fcont
4712
4713                 if (calc_grad) then
4714                 fprimcont=fprimcont/rij
4715 cd              facont_hb(num_conti,i)=1.0D0
4716 C Following line is for diagnostics.
4717 cd              fprimcont=0.0D0
4718                 do k=1,3
4719                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4720                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4721                 enddo
4722                 do k=1,3
4723                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4724                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4725                 enddo
4726                 gggp(1)=gggp(1)+ees0pijp*xj
4727                 gggp(2)=gggp(2)+ees0pijp*yj
4728                 gggp(3)=gggp(3)+ees0pijp*zj
4729                 gggm(1)=gggm(1)+ees0mijp*xj
4730                 gggm(2)=gggm(2)+ees0mijp*yj
4731                 gggm(3)=gggm(3)+ees0mijp*zj
4732 C Derivatives due to the contact function
4733                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4734                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4735                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4736                 do k=1,3
4737 c
4738 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4739 c          following the change of gradient-summation algorithm.
4740 c
4741 cgrad                  ghalfp=0.5D0*gggp(k)
4742 cgrad                  ghalfm=0.5D0*gggm(k)
4743                   gacontp_hb1(k,num_conti,i)=!ghalfp
4744      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4745      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4746      &          *fac_shield(i)*fac_shield(j)
4747
4748                   gacontp_hb2(k,num_conti,i)=!ghalfp
4749      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4750      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4751      &          *fac_shield(i)*fac_shield(j)
4752
4753                   gacontp_hb3(k,num_conti,i)=gggp(k)
4754      &          *fac_shield(i)*fac_shield(j)
4755
4756                   gacontm_hb1(k,num_conti,i)=!ghalfm
4757      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4758      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4759      &          *fac_shield(i)*fac_shield(j)
4760
4761                   gacontm_hb2(k,num_conti,i)=!ghalfm
4762      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4763      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4764      &          *fac_shield(i)*fac_shield(j)
4765
4766                   gacontm_hb3(k,num_conti,i)=gggm(k)
4767      &          *fac_shield(i)*fac_shield(j)
4768
4769                 enddo
4770 C Diagnostics. Comment out or remove after debugging!
4771 cdiag           do k=1,3
4772 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4773 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4774 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4775 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4776 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4777 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4778 cdiag           enddo
4779
4780                  endif ! calc_grad
4781
4782               ENDIF ! wcorr
4783               endif  ! num_conti.le.maxconts
4784             endif  ! fcont.gt.0
4785           endif    ! j.gt.i+1
4786           if (calc_grad) then
4787           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4788             do k=1,4
4789               do l=1,3
4790                 ghalf=0.5d0*agg(l,k)
4791                 aggi(l,k)=aggi(l,k)+ghalf
4792                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4793                 aggj(l,k)=aggj(l,k)+ghalf
4794               enddo
4795             enddo
4796             if (j.eq.nres-1 .and. i.lt.j-2) then
4797               do k=1,4
4798                 do l=1,3
4799                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4800                 enddo
4801               enddo
4802             endif
4803           endif
4804           endif ! calc_grad
4805 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4806       return
4807       end
4808 C-----------------------------------------------------------------------------
4809       subroutine eturn3(i,eello_turn3)
4810 C Third- and fourth-order contributions from turns
4811       implicit real*8 (a-h,o-z)
4812       include 'DIMENSIONS'
4813       include 'DIMENSIONS.ZSCOPT'
4814       include 'COMMON.IOUNITS'
4815       include 'COMMON.GEO'
4816       include 'COMMON.VAR'
4817       include 'COMMON.LOCAL'
4818       include 'COMMON.CHAIN'
4819       include 'COMMON.DERIV'
4820       include 'COMMON.INTERACT'
4821       include 'COMMON.CONTACTS'
4822       include 'COMMON.TORSION'
4823       include 'COMMON.VECTORS'
4824       include 'COMMON.FFIELD'
4825       include 'COMMON.CONTROL'
4826       include 'COMMON.SHIELD'
4827       dimension ggg(3)
4828       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4829      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4830      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4831      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4832      &  auxgmat2(2,2),auxgmatt2(2,2)
4833       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4834      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4835       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4836      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4837      &    num_conti,j1,j2
4838       j=i+2
4839 c      write (iout,*) "eturn3",i,j,j1,j2
4840       a_temp(1,1)=a22
4841       a_temp(1,2)=a23
4842       a_temp(2,1)=a32
4843       a_temp(2,2)=a33
4844 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4845 C
4846 C               Third-order contributions
4847 C
4848 C                 (i+2)o----(i+3)
4849 C                      | |
4850 C                      | |
4851 C                 (i+1)o----i
4852 C
4853 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4854 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4855         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4856 c auxalary matices for theta gradient
4857 c auxalary matrix for i+1 and constant i+2
4858         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4859 c auxalary matrix for i+2 and constant i+1
4860         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4861         call transpose2(auxmat(1,1),auxmat1(1,1))
4862         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4863         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4864         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4865         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4866         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4867         if (shield_mode.eq.0) then
4868         fac_shield(i)=1.0
4869         fac_shield(j)=1.0
4870 C        else
4871 C        fac_shield(i)=0.4
4872 C        fac_shield(j)=0.6
4873         endif
4874         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4875      &  *fac_shield(i)*fac_shield(j)
4876         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4877      &  *fac_shield(i)*fac_shield(j)
4878         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4879      &    eello_t3
4880         if (calc_grad) then
4881 C#ifdef NEWCORR
4882 C Derivatives in theta
4883         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4884      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4885      &   *fac_shield(i)*fac_shield(j)
4886         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4887      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4888      &   *fac_shield(i)*fac_shield(j)
4889 C#endif
4890
4891 C Derivatives in shield mode
4892           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4893      &  (shield_mode.gt.0)) then
4894 C          print *,i,j
4895
4896           do ilist=1,ishield_list(i)
4897            iresshield=shield_list(ilist,i)
4898            do k=1,3
4899            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4900 C     &      *2.0
4901            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4902      &              rlocshield
4903      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4904             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4905      &      +rlocshield
4906            enddo
4907           enddo
4908           do ilist=1,ishield_list(j)
4909            iresshield=shield_list(ilist,j)
4910            do k=1,3
4911            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4912 C     &     *2.0
4913            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4914      &              rlocshield
4915      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4916            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4917      &             +rlocshield
4918
4919            enddo
4920           enddo
4921
4922           do k=1,3
4923             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4924      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4925             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4926      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4927             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4928      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4929             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4930      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4931            enddo
4932            endif
4933
4934 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4935 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4936 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4937 cd     &    ' eello_turn3_num',4*eello_turn3_num
4938 C Derivatives in gamma(i)
4939         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4940         call transpose2(auxmat2(1,1),auxmat3(1,1))
4941         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4942         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4943      &   *fac_shield(i)*fac_shield(j)
4944 C Derivatives in gamma(i+1)
4945         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4946         call transpose2(auxmat2(1,1),auxmat3(1,1))
4947         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4948         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4949      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4950      &   *fac_shield(i)*fac_shield(j)
4951 C Cartesian derivatives
4952         do l=1,3
4953 c            ghalf1=0.5d0*agg(l,1)
4954 c            ghalf2=0.5d0*agg(l,2)
4955 c            ghalf3=0.5d0*agg(l,3)
4956 c            ghalf4=0.5d0*agg(l,4)
4957           a_temp(1,1)=aggi(l,1)!+ghalf1
4958           a_temp(1,2)=aggi(l,2)!+ghalf2
4959           a_temp(2,1)=aggi(l,3)!+ghalf3
4960           a_temp(2,2)=aggi(l,4)!+ghalf4
4961           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4962           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4963      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4964      &   *fac_shield(i)*fac_shield(j)
4965
4966           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4967           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4968           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4969           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4970           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4971           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4972      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4973      &   *fac_shield(i)*fac_shield(j)
4974           a_temp(1,1)=aggj(l,1)!+ghalf1
4975           a_temp(1,2)=aggj(l,2)!+ghalf2
4976           a_temp(2,1)=aggj(l,3)!+ghalf3
4977           a_temp(2,2)=aggj(l,4)!+ghalf4
4978           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4979           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4980      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4981      &   *fac_shield(i)*fac_shield(j)
4982           a_temp(1,1)=aggj1(l,1)
4983           a_temp(1,2)=aggj1(l,2)
4984           a_temp(2,1)=aggj1(l,3)
4985           a_temp(2,2)=aggj1(l,4)
4986           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4987           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4988      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4989      &   *fac_shield(i)*fac_shield(j)
4990         enddo
4991
4992         endif ! calc_grad
4993
4994       return
4995       end
4996 C-------------------------------------------------------------------------------
4997       subroutine eturn4(i,eello_turn4)
4998 C Third- and fourth-order contributions from turns
4999       implicit real*8 (a-h,o-z)
5000       include 'DIMENSIONS'
5001       include 'DIMENSIONS.ZSCOPT'
5002       include 'COMMON.IOUNITS'
5003       include 'COMMON.GEO'
5004       include 'COMMON.VAR'
5005       include 'COMMON.LOCAL'
5006       include 'COMMON.CHAIN'
5007       include 'COMMON.DERIV'
5008       include 'COMMON.INTERACT'
5009       include 'COMMON.CONTACTS'
5010       include 'COMMON.TORSION'
5011       include 'COMMON.VECTORS'
5012       include 'COMMON.FFIELD'
5013       include 'COMMON.CONTROL'
5014       include 'COMMON.SHIELD'
5015       dimension ggg(3)
5016       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5017      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5018      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5019      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5020      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5021      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5022      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5023       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5024      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5025       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5026      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5027      &    num_conti,j1,j2
5028       j=i+3
5029 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5030 C
5031 C               Fourth-order contributions
5032 C
5033 C                 (i+3)o----(i+4)
5034 C                     /  |
5035 C               (i+2)o   |
5036 C                     \  |
5037 C                 (i+1)o----i
5038 C
5039 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5040 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5041 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5042 c        write(iout,*)"WCHODZE W PROGRAM"
5043         a_temp(1,1)=a22
5044         a_temp(1,2)=a23
5045         a_temp(2,1)=a32
5046         a_temp(2,2)=a33
5047         iti1=itype2loc(itype(i+1))
5048         iti2=itype2loc(itype(i+2))
5049         iti3=itype2loc(itype(i+3))
5050 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5051         call transpose2(EUg(1,1,i+1),e1t(1,1))
5052         call transpose2(Eug(1,1,i+2),e2t(1,1))
5053         call transpose2(Eug(1,1,i+3),e3t(1,1))
5054 C Ematrix derivative in theta
5055         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5056         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5057         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5058         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5059 c       eta1 in derivative theta
5060         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5061         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5062 c       auxgvec is derivative of Ub2 so i+3 theta
5063         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5064 c       auxalary matrix of E i+1
5065         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5066 c        s1=0.0
5067 c        gs1=0.0
5068         s1=scalar2(b1(1,i+2),auxvec(1))
5069 c derivative of theta i+2 with constant i+3
5070         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5071 c derivative of theta i+2 with constant i+2
5072         gs32=scalar2(b1(1,i+2),auxgvec(1))
5073 c derivative of E matix in theta of i+1
5074         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5075
5076         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5077 c       ea31 in derivative theta
5078         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5079         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5080 c auxilary matrix auxgvec of Ub2 with constant E matirx
5081         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5082 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5083         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5084
5085 c        s2=0.0
5086 c        gs2=0.0
5087         s2=scalar2(b1(1,i+1),auxvec(1))
5088 c derivative of theta i+1 with constant i+3
5089         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5090 c derivative of theta i+2 with constant i+1
5091         gs21=scalar2(b1(1,i+1),auxgvec(1))
5092 c derivative of theta i+3 with constant i+1
5093         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5094 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5095 c     &  gtb1(1,i+1)
5096         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5097 c two derivatives over diffetent matrices
5098 c gtae3e2 is derivative over i+3
5099         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5100 c ae3gte2 is derivative over i+2
5101         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5102         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5103 c three possible derivative over theta E matices
5104 c i+1
5105         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5106 c i+2
5107         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5108 c i+3
5109         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5110         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5111
5112         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5113         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5114         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5115         if (shield_mode.eq.0) then
5116         fac_shield(i)=1.0
5117         fac_shield(j)=1.0
5118 C        else
5119 C        fac_shield(i)=0.6
5120 C        fac_shield(j)=0.4
5121         endif
5122         eello_turn4=eello_turn4-(s1+s2+s3)
5123      &  *fac_shield(i)*fac_shield(j)
5124         eello_t4=-(s1+s2+s3)
5125      &  *fac_shield(i)*fac_shield(j)
5126 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5127         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5128      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5129 C Now derivative over shield:
5130           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5131      &  (shield_mode.gt.0)) then
5132 C          print *,i,j
5133
5134           do ilist=1,ishield_list(i)
5135            iresshield=shield_list(ilist,i)
5136            do k=1,3
5137            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5138 C     &      *2.0
5139            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5140      &              rlocshield
5141      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5142             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5143      &      +rlocshield
5144            enddo
5145           enddo
5146           do ilist=1,ishield_list(j)
5147            iresshield=shield_list(ilist,j)
5148            do k=1,3
5149            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5150 C     &     *2.0
5151            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5152      &              rlocshield
5153      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5154            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5155      &             +rlocshield
5156
5157            enddo
5158           enddo
5159
5160           do k=1,3
5161             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5162      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5163             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5164      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5165             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5166      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5167             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5168      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5169            enddo
5170            endif
5171 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5172 cd     &    ' eello_turn4_num',8*eello_turn4_num
5173 #ifdef NEWCORR
5174         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5175      &                  -(gs13+gsE13+gsEE1)*wturn4
5176      &  *fac_shield(i)*fac_shield(j)
5177         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5178      &                    -(gs23+gs21+gsEE2)*wturn4
5179      &  *fac_shield(i)*fac_shield(j)
5180
5181         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5182      &                    -(gs32+gsE31+gsEE3)*wturn4
5183      &  *fac_shield(i)*fac_shield(j)
5184
5185 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5186 c     &   gs2
5187 #endif
5188         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5189      &      'eturn4',i,j,-(s1+s2+s3)
5190 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5191 c     &    ' eello_turn4_num',8*eello_turn4_num
5192 C Derivatives in gamma(i)
5193         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5194         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5195         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5196         s1=scalar2(b1(1,i+2),auxvec(1))
5197         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5198         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5199         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5200      &  *fac_shield(i)*fac_shield(j)
5201 C Derivatives in gamma(i+1)
5202         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5203         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5204         s2=scalar2(b1(1,i+1),auxvec(1))
5205         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5206         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5207         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5208         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5209      &  *fac_shield(i)*fac_shield(j)
5210 C Derivatives in gamma(i+2)
5211         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5212         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5213         s1=scalar2(b1(1,i+2),auxvec(1))
5214         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5215         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5216         s2=scalar2(b1(1,i+1),auxvec(1))
5217         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5218         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5219         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5220         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5221      &  *fac_shield(i)*fac_shield(j)
5222         if (calc_grad) then
5223 C Cartesian derivatives
5224 C Derivatives of this turn contributions in DC(i+2)
5225         if (j.lt.nres-1) then
5226           do l=1,3
5227             a_temp(1,1)=agg(l,1)
5228             a_temp(1,2)=agg(l,2)
5229             a_temp(2,1)=agg(l,3)
5230             a_temp(2,2)=agg(l,4)
5231             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5232             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5233             s1=scalar2(b1(1,i+2),auxvec(1))
5234             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5235             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5236             s2=scalar2(b1(1,i+1),auxvec(1))
5237             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5238             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5239             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5240             ggg(l)=-(s1+s2+s3)
5241             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5242      &  *fac_shield(i)*fac_shield(j)
5243           enddo
5244         endif
5245 C Remaining derivatives of this turn contribution
5246         do l=1,3
5247           a_temp(1,1)=aggi(l,1)
5248           a_temp(1,2)=aggi(l,2)
5249           a_temp(2,1)=aggi(l,3)
5250           a_temp(2,2)=aggi(l,4)
5251           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5252           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5253           s1=scalar2(b1(1,i+2),auxvec(1))
5254           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5255           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5256           s2=scalar2(b1(1,i+1),auxvec(1))
5257           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5258           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5259           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5260           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5261      &  *fac_shield(i)*fac_shield(j)
5262           a_temp(1,1)=aggi1(l,1)
5263           a_temp(1,2)=aggi1(l,2)
5264           a_temp(2,1)=aggi1(l,3)
5265           a_temp(2,2)=aggi1(l,4)
5266           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5267           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5268           s1=scalar2(b1(1,i+2),auxvec(1))
5269           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5270           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5271           s2=scalar2(b1(1,i+1),auxvec(1))
5272           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5273           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5274           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5275           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5276      &  *fac_shield(i)*fac_shield(j)
5277           a_temp(1,1)=aggj(l,1)
5278           a_temp(1,2)=aggj(l,2)
5279           a_temp(2,1)=aggj(l,3)
5280           a_temp(2,2)=aggj(l,4)
5281           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5282           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5283           s1=scalar2(b1(1,i+2),auxvec(1))
5284           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5285           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5286           s2=scalar2(b1(1,i+1),auxvec(1))
5287           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5288           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5289           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5290           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5291      &  *fac_shield(i)*fac_shield(j)
5292           a_temp(1,1)=aggj1(l,1)
5293           a_temp(1,2)=aggj1(l,2)
5294           a_temp(2,1)=aggj1(l,3)
5295           a_temp(2,2)=aggj1(l,4)
5296           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5297           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5298           s1=scalar2(b1(1,i+2),auxvec(1))
5299           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5300           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5301           s2=scalar2(b1(1,i+1),auxvec(1))
5302           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5303           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5304           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5305 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5306           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5307      &  *fac_shield(i)*fac_shield(j)
5308         enddo
5309
5310         endif ! calc_grad
5311
5312       return
5313       end
5314 C-----------------------------------------------------------------------------
5315       subroutine vecpr(u,v,w)
5316       implicit real*8(a-h,o-z)
5317       dimension u(3),v(3),w(3)
5318       w(1)=u(2)*v(3)-u(3)*v(2)
5319       w(2)=-u(1)*v(3)+u(3)*v(1)
5320       w(3)=u(1)*v(2)-u(2)*v(1)
5321       return
5322       end
5323 C-----------------------------------------------------------------------------
5324       subroutine unormderiv(u,ugrad,unorm,ungrad)
5325 C This subroutine computes the derivatives of a normalized vector u, given
5326 C the derivatives computed without normalization conditions, ugrad. Returns
5327 C ungrad.
5328       implicit none
5329       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5330       double precision vec(3)
5331       double precision scalar
5332       integer i,j
5333 c      write (2,*) 'ugrad',ugrad
5334 c      write (2,*) 'u',u
5335       do i=1,3
5336         vec(i)=scalar(ugrad(1,i),u(1))
5337       enddo
5338 c      write (2,*) 'vec',vec
5339       do i=1,3
5340         do j=1,3
5341           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5342         enddo
5343       enddo
5344 c      write (2,*) 'ungrad',ungrad
5345       return
5346       end
5347 C-----------------------------------------------------------------------------
5348       subroutine escp(evdw2,evdw2_14)
5349 C
5350 C This subroutine calculates the excluded-volume interaction energy between
5351 C peptide-group centers and side chains and its gradient in virtual-bond and
5352 C side-chain vectors.
5353 C
5354       implicit real*8 (a-h,o-z)
5355       include 'DIMENSIONS'
5356       include 'DIMENSIONS.ZSCOPT'
5357       include 'COMMON.GEO'
5358       include 'COMMON.VAR'
5359       include 'COMMON.LOCAL'
5360       include 'COMMON.CHAIN'
5361       include 'COMMON.DERIV'
5362       include 'COMMON.INTERACT'
5363       include 'COMMON.FFIELD'
5364       include 'COMMON.IOUNITS'
5365       dimension ggg(3)
5366       evdw2=0.0D0
5367       evdw2_14=0.0d0
5368 cd    print '(a)','Enter ESCP'
5369 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
5370 c     &  ' scal14',scal14
5371       do i=iatscp_s,iatscp_e
5372         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5373         iteli=itel(i)
5374 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
5375 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
5376         if (iteli.eq.0) goto 1225
5377         xi=0.5D0*(c(1,i)+c(1,i+1))
5378         yi=0.5D0*(c(2,i)+c(2,i+1))
5379         zi=0.5D0*(c(3,i)+c(3,i+1))
5380 C Returning the ith atom to box
5381           xi=mod(xi,boxxsize)
5382           if (xi.lt.0) xi=xi+boxxsize
5383           yi=mod(yi,boxysize)
5384           if (yi.lt.0) yi=yi+boxysize
5385           zi=mod(zi,boxzsize)
5386           if (zi.lt.0) zi=zi+boxzsize
5387         do iint=1,nscp_gr(i)
5388
5389         do j=iscpstart(i,iint),iscpend(i,iint)
5390           itypj=iabs(itype(j))
5391           if (itypj.eq.ntyp1) cycle
5392 C Uncomment following three lines for SC-p interactions
5393 c         xj=c(1,nres+j)-xi
5394 c         yj=c(2,nres+j)-yi
5395 c         zj=c(3,nres+j)-zi
5396 C Uncomment following three lines for Ca-p interactions
5397           xj=c(1,j)
5398           yj=c(2,j)
5399           zj=c(3,j)
5400 C returning the jth atom to box
5401           xj=mod(xj,boxxsize)
5402           if (xj.lt.0) xj=xj+boxxsize
5403           yj=mod(yj,boxysize)
5404           if (yj.lt.0) yj=yj+boxysize
5405           zj=mod(zj,boxzsize)
5406           if (zj.lt.0) zj=zj+boxzsize
5407       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5408       xj_safe=xj
5409       yj_safe=yj
5410       zj_safe=zj
5411       subchap=0
5412 C Finding the closest jth atom
5413       do xshift=-1,1
5414       do yshift=-1,1
5415       do zshift=-1,1
5416           xj=xj_safe+xshift*boxxsize
5417           yj=yj_safe+yshift*boxysize
5418           zj=zj_safe+zshift*boxzsize
5419           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5420           if(dist_temp.lt.dist_init) then
5421             dist_init=dist_temp
5422             xj_temp=xj
5423             yj_temp=yj
5424             zj_temp=zj
5425             subchap=1
5426           endif
5427        enddo
5428        enddo
5429        enddo
5430        if (subchap.eq.1) then
5431           xj=xj_temp-xi
5432           yj=yj_temp-yi
5433           zj=zj_temp-zi
5434        else
5435           xj=xj_safe-xi
5436           yj=yj_safe-yi
5437           zj=zj_safe-zi
5438        endif
5439           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5440 C sss is scaling function for smoothing the cutoff gradient otherwise
5441 C the gradient would not be continuouse
5442           sss=sscale(1.0d0/(dsqrt(rrij)))
5443           if (sss.le.0.0d0) cycle
5444           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5445           fac=rrij**expon2
5446           e1=fac*fac*aad(itypj,iteli)
5447           e2=fac*bad(itypj,iteli)
5448           if (iabs(j-i) .le. 2) then
5449             e1=scal14*e1
5450             e2=scal14*e2
5451             evdw2_14=evdw2_14+(e1+e2)*sss
5452           endif
5453           evdwij=e1+e2
5454 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5455 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5456 c     &       bad(itypj,iteli)
5457           evdw2=evdw2+evdwij*sss
5458           if (calc_grad) then
5459 C
5460 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5461 C
5462           fac=-(evdwij+e1)*rrij*sss
5463           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5464           ggg(1)=xj*fac
5465           ggg(2)=yj*fac
5466           ggg(3)=zj*fac
5467           if (j.lt.i) then
5468 cd          write (iout,*) 'j<i'
5469 C Uncomment following three lines for SC-p interactions
5470 c           do k=1,3
5471 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5472 c           enddo
5473           else
5474 cd          write (iout,*) 'j>i'
5475             do k=1,3
5476               ggg(k)=-ggg(k)
5477 C Uncomment following line for SC-p interactions
5478 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5479             enddo
5480           endif
5481           do k=1,3
5482             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5483           enddo
5484           kstart=min0(i+1,j)
5485           kend=max0(i-1,j-1)
5486 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5487 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5488           do k=kstart,kend
5489             do l=1,3
5490               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5491             enddo
5492           enddo
5493           endif ! calc_grad
5494         enddo
5495         enddo ! iint
5496  1225   continue
5497       enddo ! i
5498       do i=1,nct
5499         do j=1,3
5500           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5501           gradx_scp(j,i)=expon*gradx_scp(j,i)
5502         enddo
5503       enddo
5504 C******************************************************************************
5505 C
5506 C                              N O T E !!!
5507 C
5508 C To save time the factor EXPON has been extracted from ALL components
5509 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5510 C use!
5511 C
5512 C******************************************************************************
5513       return
5514       end
5515 C--------------------------------------------------------------------------
5516       subroutine edis(ehpb)
5517 C
5518 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5519 C
5520       implicit real*8 (a-h,o-z)
5521       include 'DIMENSIONS'
5522       include 'DIMENSIONS.ZSCOPT'
5523       include 'COMMON.SBRIDGE'
5524       include 'COMMON.CHAIN'
5525       include 'COMMON.DERIV'
5526       include 'COMMON.VAR'
5527       include 'COMMON.INTERACT'
5528       include 'COMMON.CONTROL'
5529       include 'COMMON.IOUNITS'
5530       dimension ggg(3)
5531       ehpb=0.0D0
5532 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
5533 cd    print *,'link_start=',link_start,' link_end=',link_end
5534 C      write(iout,*) link_end, "link_end"
5535       if (link_end.eq.0) return
5536       do i=link_start,link_end
5537 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5538 C CA-CA distance used in regularization of structure.
5539         ii=ihpb(i)
5540         jj=jhpb(i)
5541 C iii and jjj point to the residues for which the distance is assigned.
5542         if (ii.gt.nres) then
5543           iii=ii-nres
5544           jjj=jj-nres
5545         else
5546           iii=ii
5547           jjj=jj
5548         endif
5549 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5550 C    distance and angle dependent SS bond potential.
5551 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5552 C     & iabs(itype(jjj)).eq.1) then
5553 C       write(iout,*) constr_dist,"const"
5554        if (.not.dyn_ss .and. i.le.nss) then
5555          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5556      & iabs(itype(jjj)).eq.1) then
5557           call ssbond_ene(iii,jjj,eij)
5558           ehpb=ehpb+2*eij
5559            endif !ii.gt.neres
5560         else if (ii.gt.nres .and. jj.gt.nres) then
5561 c Restraints from contact prediction
5562           dd=dist(ii,jj)
5563           if (constr_dist.eq.11) then
5564 C            ehpb=ehpb+fordepth(i)**4.0d0
5565 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5566             ehpb=ehpb+fordepth(i)**4.0d0
5567      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5568             fac=fordepth(i)**4.0d0
5569      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5570 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5571 C     &    ehpb,fordepth(i),dd
5572 C            write(iout,*) ehpb,"atu?"
5573 C            ehpb,"tu?"
5574 C            fac=fordepth(i)**4.0d0
5575 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5576            else
5577           if (dhpb1(i).gt.0.0d0) then
5578             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5579             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5580 c            write (iout,*) "beta nmr",
5581 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5582           else
5583             dd=dist(ii,jj)
5584             rdis=dd-dhpb(i)
5585 C Get the force constant corresponding to this distance.
5586             waga=forcon(i)
5587 C Calculate the contribution to energy.
5588             ehpb=ehpb+waga*rdis*rdis
5589 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5590 C
5591 C Evaluate gradient.
5592 C
5593             fac=waga*rdis/dd
5594           endif !end dhpb1(i).gt.0
5595           endif !end const_dist=11
5596           do j=1,3
5597             ggg(j)=fac*(c(j,jj)-c(j,ii))
5598           enddo
5599           do j=1,3
5600             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5601             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5602           enddo
5603           do k=1,3
5604             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5605             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5606           enddo
5607         else !ii.gt.nres
5608 C          write(iout,*) "before"
5609           dd=dist(ii,jj)
5610 C          write(iout,*) "after",dd
5611           if (constr_dist.eq.11) then
5612             ehpb=ehpb+fordepth(i)**4.0d0
5613      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5614             fac=fordepth(i)**4.0d0
5615      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5616 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
5617 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
5618 C            print *,ehpb,"tu?"
5619 C            write(iout,*) ehpb,"btu?",
5620 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
5621 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5622 C     &    ehpb,fordepth(i),dd
5623            else
5624           if (dhpb1(i).gt.0.0d0) then
5625             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5626             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5627 c            write (iout,*) "alph nmr",
5628 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5629           else
5630             rdis=dd-dhpb(i)
5631 C Get the force constant corresponding to this distance.
5632             waga=forcon(i)
5633 C Calculate the contribution to energy.
5634             ehpb=ehpb+waga*rdis*rdis
5635 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5636 C
5637 C Evaluate gradient.
5638 C
5639             fac=waga*rdis/dd
5640           endif
5641           endif
5642
5643         do j=1,3
5644           ggg(j)=fac*(c(j,jj)-c(j,ii))
5645         enddo
5646 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5647 C If this is a SC-SC distance, we need to calculate the contributions to the
5648 C Cartesian gradient in the SC vectors (ghpbx).
5649         if (iii.lt.ii) then
5650           do j=1,3
5651             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5652             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5653           enddo
5654         endif
5655         do j=iii,jjj-1
5656           do k=1,3
5657             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5658           enddo
5659         enddo
5660         endif
5661       enddo
5662       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5663       return
5664       end
5665 C--------------------------------------------------------------------------
5666       subroutine ssbond_ene(i,j,eij)
5667 C
5668 C Calculate the distance and angle dependent SS-bond potential energy
5669 C using a free-energy function derived based on RHF/6-31G** ab initio
5670 C calculations of diethyl disulfide.
5671 C
5672 C A. Liwo and U. Kozlowska, 11/24/03
5673 C
5674       implicit real*8 (a-h,o-z)
5675       include 'DIMENSIONS'
5676       include 'DIMENSIONS.ZSCOPT'
5677       include 'COMMON.SBRIDGE'
5678       include 'COMMON.CHAIN'
5679       include 'COMMON.DERIV'
5680       include 'COMMON.LOCAL'
5681       include 'COMMON.INTERACT'
5682       include 'COMMON.VAR'
5683       include 'COMMON.IOUNITS'
5684       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5685       itypi=iabs(itype(i))
5686       xi=c(1,nres+i)
5687       yi=c(2,nres+i)
5688       zi=c(3,nres+i)
5689       dxi=dc_norm(1,nres+i)
5690       dyi=dc_norm(2,nres+i)
5691       dzi=dc_norm(3,nres+i)
5692       dsci_inv=dsc_inv(itypi)
5693       itypj=iabs(itype(j))
5694       dscj_inv=dsc_inv(itypj)
5695       xj=c(1,nres+j)-xi
5696       yj=c(2,nres+j)-yi
5697       zj=c(3,nres+j)-zi
5698       dxj=dc_norm(1,nres+j)
5699       dyj=dc_norm(2,nres+j)
5700       dzj=dc_norm(3,nres+j)
5701       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5702       rij=dsqrt(rrij)
5703       erij(1)=xj*rij
5704       erij(2)=yj*rij
5705       erij(3)=zj*rij
5706       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5707       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5708       om12=dxi*dxj+dyi*dyj+dzi*dzj
5709       do k=1,3
5710         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5711         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5712       enddo
5713       rij=1.0d0/rij
5714       deltad=rij-d0cm
5715       deltat1=1.0d0-om1
5716       deltat2=1.0d0+om2
5717       deltat12=om2-om1+2.0d0
5718       cosphi=om12-om1*om2
5719       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5720      &  +akct*deltad*deltat12
5721      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
5722 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5723 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5724 c     &  " deltat12",deltat12," eij",eij
5725       ed=2*akcm*deltad+akct*deltat12
5726       pom1=akct*deltad
5727       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5728       eom1=-2*akth*deltat1-pom1-om2*pom2
5729       eom2= 2*akth*deltat2+pom1-om1*pom2
5730       eom12=pom2
5731       do k=1,3
5732         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5733       enddo
5734       do k=1,3
5735         ghpbx(k,i)=ghpbx(k,i)-gg(k)
5736      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
5737         ghpbx(k,j)=ghpbx(k,j)+gg(k)
5738      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
5739       enddo
5740 C
5741 C Calculate the components of the gradient in DC and X
5742 C
5743       do k=i,j-1
5744         do l=1,3
5745           ghpbc(l,k)=ghpbc(l,k)+gg(l)
5746         enddo
5747       enddo
5748       return
5749       end
5750 C--------------------------------------------------------------------------
5751       subroutine ebond(estr)
5752 c
5753 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5754 c
5755       implicit real*8 (a-h,o-z)
5756       include 'DIMENSIONS'
5757       include 'DIMENSIONS.ZSCOPT'
5758       include 'COMMON.LOCAL'
5759       include 'COMMON.GEO'
5760       include 'COMMON.INTERACT'
5761       include 'COMMON.DERIV'
5762       include 'COMMON.VAR'
5763       include 'COMMON.CHAIN'
5764       include 'COMMON.IOUNITS'
5765       include 'COMMON.NAMES'
5766       include 'COMMON.FFIELD'
5767       include 'COMMON.CONTROL'
5768       double precision u(3),ud(3)
5769       estr=0.0d0
5770       estr1=0.0d0
5771 c      write (iout,*) "distchainmax",distchainmax
5772       do i=nnt+1,nct
5773         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5774 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5775 C          do j=1,3
5776 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5777 C     &      *dc(j,i-1)/vbld(i)
5778 C          enddo
5779 C          if (energy_dec) write(iout,*)
5780 C     &       "estr1",i,vbld(i),distchainmax,
5781 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5782 C        else
5783          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5784         diff = vbld(i)-vbldpDUM
5785 C         write(iout,*) i,diff
5786          else
5787           diff = vbld(i)-vbldp0
5788 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5789          endif
5790           estr=estr+diff*diff
5791           do j=1,3
5792             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5793           enddo
5794 C        endif
5795 C        write (iout,'(a7,i5,4f7.3)')
5796 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5797       enddo
5798       estr=0.5d0*AKP*estr+estr1
5799 c
5800 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5801 c
5802       do i=nnt,nct
5803         iti=iabs(itype(i))
5804         if (iti.ne.10 .and. iti.ne.ntyp1) then
5805           nbi=nbondterm(iti)
5806           if (nbi.eq.1) then
5807             diff=vbld(i+nres)-vbldsc0(1,iti)
5808 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5809 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5810             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5811             do j=1,3
5812               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5813             enddo
5814           else
5815             do j=1,nbi
5816               diff=vbld(i+nres)-vbldsc0(j,iti)
5817               ud(j)=aksc(j,iti)*diff
5818               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5819             enddo
5820             uprod=u(1)
5821             do j=2,nbi
5822               uprod=uprod*u(j)
5823             enddo
5824             usum=0.0d0
5825             usumsqder=0.0d0
5826             do j=1,nbi
5827               uprod1=1.0d0
5828               uprod2=1.0d0
5829               do k=1,nbi
5830                 if (k.ne.j) then
5831                   uprod1=uprod1*u(k)
5832                   uprod2=uprod2*u(k)*u(k)
5833                 endif
5834               enddo
5835               usum=usum+uprod1
5836               usumsqder=usumsqder+ud(j)*uprod2
5837             enddo
5838 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5839 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5840             estr=estr+uprod/usum
5841             do j=1,3
5842              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5843             enddo
5844           endif
5845         endif
5846       enddo
5847       return
5848       end
5849 #ifdef CRYST_THETA
5850 C--------------------------------------------------------------------------
5851       subroutine ebend(etheta,ethetacnstr)
5852 C
5853 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5854 C angles gamma and its derivatives in consecutive thetas and gammas.
5855 C
5856       implicit real*8 (a-h,o-z)
5857       include 'DIMENSIONS'
5858       include 'DIMENSIONS.ZSCOPT'
5859       include 'COMMON.LOCAL'
5860       include 'COMMON.GEO'
5861       include 'COMMON.INTERACT'
5862       include 'COMMON.DERIV'
5863       include 'COMMON.VAR'
5864       include 'COMMON.CHAIN'
5865       include 'COMMON.IOUNITS'
5866       include 'COMMON.NAMES'
5867       include 'COMMON.FFIELD'
5868       include 'COMMON.TORCNSTR'
5869       common /calcthet/ term1,term2,termm,diffak,ratak,
5870      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5871      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5872       double precision y(2),z(2)
5873       delta=0.02d0*pi
5874 c      time11=dexp(-2*time)
5875 c      time12=1.0d0
5876       etheta=0.0D0
5877 c      write (iout,*) "nres",nres
5878 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5879 c      write (iout,*) ithet_start,ithet_end
5880       do i=ithet_start,ithet_end
5881 C        if (itype(i-1).eq.ntyp1) cycle
5882         if (i.le.2) cycle
5883         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5884      &  .or.itype(i).eq.ntyp1) cycle
5885 C Zero the energy function and its derivative at 0 or pi.
5886         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5887         it=itype(i-1)
5888         ichir1=isign(1,itype(i-2))
5889         ichir2=isign(1,itype(i))
5890          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5891          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5892          if (itype(i-1).eq.10) then
5893           itype1=isign(10,itype(i-2))
5894           ichir11=isign(1,itype(i-2))
5895           ichir12=isign(1,itype(i-2))
5896           itype2=isign(10,itype(i))
5897           ichir21=isign(1,itype(i))
5898           ichir22=isign(1,itype(i))
5899          endif
5900          if (i.eq.3) then
5901           y(1)=0.0D0
5902           y(2)=0.0D0
5903           else
5904
5905         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5906 #ifdef OSF
5907           phii=phi(i)
5908 c          icrc=0
5909 c          call proc_proc(phii,icrc)
5910           if (icrc.eq.1) phii=150.0
5911 #else
5912           phii=phi(i)
5913 #endif
5914           y(1)=dcos(phii)
5915           y(2)=dsin(phii)
5916         else
5917           y(1)=0.0D0
5918           y(2)=0.0D0
5919         endif
5920         endif
5921         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5922 #ifdef OSF
5923           phii1=phi(i+1)
5924 c          icrc=0
5925 c          call proc_proc(phii1,icrc)
5926           if (icrc.eq.1) phii1=150.0
5927           phii1=pinorm(phii1)
5928           z(1)=cos(phii1)
5929 #else
5930           phii1=phi(i+1)
5931           z(1)=dcos(phii1)
5932 #endif
5933           z(2)=dsin(phii1)
5934         else
5935           z(1)=0.0D0
5936           z(2)=0.0D0
5937         endif
5938 C Calculate the "mean" value of theta from the part of the distribution
5939 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5940 C In following comments this theta will be referred to as t_c.
5941         thet_pred_mean=0.0d0
5942         do k=1,2
5943             athetk=athet(k,it,ichir1,ichir2)
5944             bthetk=bthet(k,it,ichir1,ichir2)
5945           if (it.eq.10) then
5946              athetk=athet(k,itype1,ichir11,ichir12)
5947              bthetk=bthet(k,itype2,ichir21,ichir22)
5948           endif
5949           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5950         enddo
5951 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5952         dthett=thet_pred_mean*ssd
5953         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5954 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5955 C Derivatives of the "mean" values in gamma1 and gamma2.
5956         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5957      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5958          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5959      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5960          if (it.eq.10) then
5961       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5962      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5963         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5964      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5965          endif
5966         if (theta(i).gt.pi-delta) then
5967           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5968      &         E_tc0)
5969           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5970           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5971           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5972      &        E_theta)
5973           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5974      &        E_tc)
5975         else if (theta(i).lt.delta) then
5976           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5977           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5978           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5979      &        E_theta)
5980           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5981           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5982      &        E_tc)
5983         else
5984           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5985      &        E_theta,E_tc)
5986         endif
5987         etheta=etheta+ethetai
5988 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5989 c     &      'ebend',i,ethetai,theta(i),itype(i)
5990 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5991 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5992         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5993         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5994         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5995 c 1215   continue
5996       enddo
5997       ethetacnstr=0.0d0
5998 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5999       do i=1,ntheta_constr
6000         itheta=itheta_constr(i)
6001         thetiii=theta(itheta)
6002         difi=pinorm(thetiii-theta_constr0(i))
6003         if (difi.gt.theta_drange(i)) then
6004           difi=difi-theta_drange(i)
6005           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6006           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6007      &    +for_thet_constr(i)*difi**3
6008         else if (difi.lt.-drange(i)) then
6009           difi=difi+drange(i)
6010           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6011           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6012      &    +for_thet_constr(i)*difi**3
6013         else
6014           difi=0.0
6015         endif
6016 C       if (energy_dec) then
6017 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6018 C     &    i,itheta,rad2deg*thetiii,
6019 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6020 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6021 C     &    gloc(itheta+nphi-2,icg)
6022 C        endif
6023       enddo
6024 C Ufff.... We've done all this!!!
6025       return
6026       end
6027 C---------------------------------------------------------------------------
6028       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6029      &     E_tc)
6030       implicit real*8 (a-h,o-z)
6031       include 'DIMENSIONS'
6032       include 'COMMON.LOCAL'
6033       include 'COMMON.IOUNITS'
6034       common /calcthet/ term1,term2,termm,diffak,ratak,
6035      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6036      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6037 C Calculate the contributions to both Gaussian lobes.
6038 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6039 C The "polynomial part" of the "standard deviation" of this part of
6040 C the distribution.
6041         sig=polthet(3,it)
6042         do j=2,0,-1
6043           sig=sig*thet_pred_mean+polthet(j,it)
6044         enddo
6045 C Derivative of the "interior part" of the "standard deviation of the"
6046 C gamma-dependent Gaussian lobe in t_c.
6047         sigtc=3*polthet(3,it)
6048         do j=2,1,-1
6049           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6050         enddo
6051         sigtc=sig*sigtc
6052 C Set the parameters of both Gaussian lobes of the distribution.
6053 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6054         fac=sig*sig+sigc0(it)
6055         sigcsq=fac+fac
6056         sigc=1.0D0/sigcsq
6057 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6058         sigsqtc=-4.0D0*sigcsq*sigtc
6059 c       print *,i,sig,sigtc,sigsqtc
6060 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6061         sigtc=-sigtc/(fac*fac)
6062 C Following variable is sigma(t_c)**(-2)
6063         sigcsq=sigcsq*sigcsq
6064         sig0i=sig0(it)
6065         sig0inv=1.0D0/sig0i**2
6066         delthec=thetai-thet_pred_mean
6067         delthe0=thetai-theta0i
6068         term1=-0.5D0*sigcsq*delthec*delthec
6069         term2=-0.5D0*sig0inv*delthe0*delthe0
6070 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6071 C NaNs in taking the logarithm. We extract the largest exponent which is added
6072 C to the energy (this being the log of the distribution) at the end of energy
6073 C term evaluation for this virtual-bond angle.
6074         if (term1.gt.term2) then
6075           termm=term1
6076           term2=dexp(term2-termm)
6077           term1=1.0d0
6078         else
6079           termm=term2
6080           term1=dexp(term1-termm)
6081           term2=1.0d0
6082         endif
6083 C The ratio between the gamma-independent and gamma-dependent lobes of
6084 C the distribution is a Gaussian function of thet_pred_mean too.
6085         diffak=gthet(2,it)-thet_pred_mean
6086         ratak=diffak/gthet(3,it)**2
6087         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6088 C Let's differentiate it in thet_pred_mean NOW.
6089         aktc=ak*ratak
6090 C Now put together the distribution terms to make complete distribution.
6091         termexp=term1+ak*term2
6092         termpre=sigc+ak*sig0i
6093 C Contribution of the bending energy from this theta is just the -log of
6094 C the sum of the contributions from the two lobes and the pre-exponential
6095 C factor. Simple enough, isn't it?
6096         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6097 C NOW the derivatives!!!
6098 C 6/6/97 Take into account the deformation.
6099         E_theta=(delthec*sigcsq*term1
6100      &       +ak*delthe0*sig0inv*term2)/termexp
6101         E_tc=((sigtc+aktc*sig0i)/termpre
6102      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6103      &       aktc*term2)/termexp)
6104       return
6105       end
6106 c-----------------------------------------------------------------------------
6107       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6108       implicit real*8 (a-h,o-z)
6109       include 'DIMENSIONS'
6110       include 'COMMON.LOCAL'
6111       include 'COMMON.IOUNITS'
6112       common /calcthet/ term1,term2,termm,diffak,ratak,
6113      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6114      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6115       delthec=thetai-thet_pred_mean
6116       delthe0=thetai-theta0i
6117 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6118       t3 = thetai-thet_pred_mean
6119       t6 = t3**2
6120       t9 = term1
6121       t12 = t3*sigcsq
6122       t14 = t12+t6*sigsqtc
6123       t16 = 1.0d0
6124       t21 = thetai-theta0i
6125       t23 = t21**2
6126       t26 = term2
6127       t27 = t21*t26
6128       t32 = termexp
6129       t40 = t32**2
6130       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6131      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6132      & *(-t12*t9-ak*sig0inv*t27)
6133       return
6134       end
6135 #else
6136 C--------------------------------------------------------------------------
6137       subroutine ebend(etheta)
6138 C
6139 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6140 C angles gamma and its derivatives in consecutive thetas and gammas.
6141 C ab initio-derived potentials from
6142 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6143 C
6144       implicit real*8 (a-h,o-z)
6145       include 'DIMENSIONS'
6146       include 'DIMENSIONS.ZSCOPT'
6147       include 'COMMON.LOCAL'
6148       include 'COMMON.GEO'
6149       include 'COMMON.INTERACT'
6150       include 'COMMON.DERIV'
6151       include 'COMMON.VAR'
6152       include 'COMMON.CHAIN'
6153       include 'COMMON.IOUNITS'
6154       include 'COMMON.NAMES'
6155       include 'COMMON.FFIELD'
6156       include 'COMMON.CONTROL'
6157       include 'COMMON.TORCNSTR'
6158       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6159      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6160      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6161      & sinph1ph2(maxdouble,maxdouble)
6162       logical lprn /.false./, lprn1 /.false./
6163       etheta=0.0D0
6164 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
6165       do i=ithet_start,ithet_end
6166 C         if (i.eq.2) cycle
6167 C        if (itype(i-1).eq.ntyp1) cycle
6168         if (i.le.2) cycle
6169         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6170      &  .or.itype(i).eq.ntyp1) cycle
6171         if (iabs(itype(i+1)).eq.20) iblock=2
6172         if (iabs(itype(i+1)).ne.20) iblock=1
6173         dethetai=0.0d0
6174         dephii=0.0d0
6175         dephii1=0.0d0
6176         theti2=0.5d0*theta(i)
6177         ityp2=ithetyp((itype(i-1)))
6178         do k=1,nntheterm
6179           coskt(k)=dcos(k*theti2)
6180           sinkt(k)=dsin(k*theti2)
6181         enddo
6182         if (i.eq.3) then
6183           phii=0.0d0
6184           ityp1=nthetyp+1
6185           do k=1,nsingle
6186             cosph1(k)=0.0d0
6187             sinph1(k)=0.0d0
6188           enddo
6189         else
6190         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6191 #ifdef OSF
6192           phii=phi(i)
6193           if (phii.ne.phii) phii=150.0
6194 #else
6195           phii=phi(i)
6196 #endif
6197           ityp1=ithetyp((itype(i-2)))
6198           do k=1,nsingle
6199             cosph1(k)=dcos(k*phii)
6200             sinph1(k)=dsin(k*phii)
6201           enddo
6202         else
6203           phii=0.0d0
6204 c          ityp1=nthetyp+1
6205           do k=1,nsingle
6206             ityp1=ithetyp((itype(i-2)))
6207             cosph1(k)=0.0d0
6208             sinph1(k)=0.0d0
6209           enddo
6210         endif
6211         endif
6212         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6213 #ifdef OSF
6214           phii1=phi(i+1)
6215           if (phii1.ne.phii1) phii1=150.0
6216           phii1=pinorm(phii1)
6217 #else
6218           phii1=phi(i+1)
6219 #endif
6220           ityp3=ithetyp((itype(i)))
6221           do k=1,nsingle
6222             cosph2(k)=dcos(k*phii1)
6223             sinph2(k)=dsin(k*phii1)
6224           enddo
6225         else
6226           phii1=0.0d0
6227 c          ityp3=nthetyp+1
6228           ityp3=ithetyp((itype(i)))
6229           do k=1,nsingle
6230             cosph2(k)=0.0d0
6231             sinph2(k)=0.0d0
6232           enddo
6233         endif
6234 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
6235 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
6236 c        call flush(iout)
6237         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6238         do k=1,ndouble
6239           do l=1,k-1
6240             ccl=cosph1(l)*cosph2(k-l)
6241             ssl=sinph1(l)*sinph2(k-l)
6242             scl=sinph1(l)*cosph2(k-l)
6243             csl=cosph1(l)*sinph2(k-l)
6244             cosph1ph2(l,k)=ccl-ssl
6245             cosph1ph2(k,l)=ccl+ssl
6246             sinph1ph2(l,k)=scl+csl
6247             sinph1ph2(k,l)=scl-csl
6248           enddo
6249         enddo
6250         if (lprn) then
6251         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6252      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6253         write (iout,*) "coskt and sinkt"
6254         do k=1,nntheterm
6255           write (iout,*) k,coskt(k),sinkt(k)
6256         enddo
6257         endif
6258         do k=1,ntheterm
6259           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6260           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6261      &      *coskt(k)
6262           if (lprn)
6263      &    write (iout,*) "k",k,"
6264      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6265      &     " ethetai",ethetai
6266         enddo
6267         if (lprn) then
6268         write (iout,*) "cosph and sinph"
6269         do k=1,nsingle
6270           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6271         enddo
6272         write (iout,*) "cosph1ph2 and sinph2ph2"
6273         do k=2,ndouble
6274           do l=1,k-1
6275             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6276      &         sinph1ph2(l,k),sinph1ph2(k,l)
6277           enddo
6278         enddo
6279         write(iout,*) "ethetai",ethetai
6280         endif
6281         do m=1,ntheterm2
6282           do k=1,nsingle
6283             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6284      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6285      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6286      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6287             ethetai=ethetai+sinkt(m)*aux
6288             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6289             dephii=dephii+k*sinkt(m)*(
6290      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6291      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6292             dephii1=dephii1+k*sinkt(m)*(
6293      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6294      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6295             if (lprn)
6296      &      write (iout,*) "m",m," k",k," bbthet",
6297      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6298      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6299      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6300      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6301           enddo
6302         enddo
6303         if (lprn)
6304      &  write(iout,*) "ethetai",ethetai
6305         do m=1,ntheterm3
6306           do k=2,ndouble
6307             do l=1,k-1
6308               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6309      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6310      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6311      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6312               ethetai=ethetai+sinkt(m)*aux
6313               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6314               dephii=dephii+l*sinkt(m)*(
6315      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6316      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6317      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6318      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6319               dephii1=dephii1+(k-l)*sinkt(m)*(
6320      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6321      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6322      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6323      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6324               if (lprn) then
6325               write (iout,*) "m",m," k",k," l",l," ffthet",
6326      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6327      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6328      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6329      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6330      &            " ethetai",ethetai
6331               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6332      &            cosph1ph2(k,l)*sinkt(m),
6333      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6334               endif
6335             enddo
6336           enddo
6337         enddo
6338 10      continue
6339         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6340      &   i,theta(i)*rad2deg,phii*rad2deg,
6341      &   phii1*rad2deg,ethetai
6342         etheta=etheta+ethetai
6343         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6344         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6345 c        gloc(nphi+i-2,icg)=wang*dethetai
6346         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6347       enddo
6348       return
6349       end
6350 #endif
6351 #ifdef CRYST_SC
6352 c-----------------------------------------------------------------------------
6353       subroutine esc(escloc)
6354 C Calculate the local energy of a side chain and its derivatives in the
6355 C corresponding virtual-bond valence angles THETA and the spherical angles
6356 C ALPHA and OMEGA.
6357       implicit real*8 (a-h,o-z)
6358       include 'DIMENSIONS'
6359       include 'DIMENSIONS.ZSCOPT'
6360       include 'COMMON.GEO'
6361       include 'COMMON.LOCAL'
6362       include 'COMMON.VAR'
6363       include 'COMMON.INTERACT'
6364       include 'COMMON.DERIV'
6365       include 'COMMON.CHAIN'
6366       include 'COMMON.IOUNITS'
6367       include 'COMMON.NAMES'
6368       include 'COMMON.FFIELD'
6369       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6370      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6371       common /sccalc/ time11,time12,time112,theti,it,nlobit
6372       delta=0.02d0*pi
6373       escloc=0.0D0
6374 C      write (iout,*) 'ESC'
6375       do i=loc_start,loc_end
6376         it=itype(i)
6377         if (it.eq.ntyp1) cycle
6378         if (it.eq.10) goto 1
6379         nlobit=nlob(iabs(it))
6380 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6381 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6382         theti=theta(i+1)-pipol
6383         x(1)=dtan(theti)
6384         x(2)=alph(i)
6385         x(3)=omeg(i)
6386 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
6387
6388         if (x(2).gt.pi-delta) then
6389           xtemp(1)=x(1)
6390           xtemp(2)=pi-delta
6391           xtemp(3)=x(3)
6392           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6393           xtemp(2)=pi
6394           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6395           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6396      &        escloci,dersc(2))
6397           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6398      &        ddersc0(1),dersc(1))
6399           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6400      &        ddersc0(3),dersc(3))
6401           xtemp(2)=pi-delta
6402           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6403           xtemp(2)=pi
6404           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6405           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6406      &            dersc0(2),esclocbi,dersc02)
6407           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6408      &            dersc12,dersc01)
6409           call splinthet(x(2),0.5d0*delta,ss,ssd)
6410           dersc0(1)=dersc01
6411           dersc0(2)=dersc02
6412           dersc0(3)=0.0d0
6413           do k=1,3
6414             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6415           enddo
6416           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6417           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6418      &             esclocbi,ss,ssd
6419           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6420 c         escloci=esclocbi
6421 c         write (iout,*) escloci
6422         else if (x(2).lt.delta) then
6423           xtemp(1)=x(1)
6424           xtemp(2)=delta
6425           xtemp(3)=x(3)
6426           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6427           xtemp(2)=0.0d0
6428           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6429           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6430      &        escloci,dersc(2))
6431           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6432      &        ddersc0(1),dersc(1))
6433           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6434      &        ddersc0(3),dersc(3))
6435           xtemp(2)=delta
6436           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6437           xtemp(2)=0.0d0
6438           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6439           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6440      &            dersc0(2),esclocbi,dersc02)
6441           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6442      &            dersc12,dersc01)
6443           dersc0(1)=dersc01
6444           dersc0(2)=dersc02
6445           dersc0(3)=0.0d0
6446           call splinthet(x(2),0.5d0*delta,ss,ssd)
6447           do k=1,3
6448             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6449           enddo
6450           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6451 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6452 c     &             esclocbi,ss,ssd
6453           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6454 C         write (iout,*) 'i=',i, escloci
6455         else
6456           call enesc(x,escloci,dersc,ddummy,.false.)
6457         endif
6458
6459         escloc=escloc+escloci
6460 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6461             write (iout,'(a6,i5,0pf7.3)')
6462      &     'escloc',i,escloci
6463
6464         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6465      &   wscloc*dersc(1)
6466         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6467         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6468     1   continue
6469       enddo
6470       return
6471       end
6472 C---------------------------------------------------------------------------
6473       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6474       implicit real*8 (a-h,o-z)
6475       include 'DIMENSIONS'
6476       include 'COMMON.GEO'
6477       include 'COMMON.LOCAL'
6478       include 'COMMON.IOUNITS'
6479       common /sccalc/ time11,time12,time112,theti,it,nlobit
6480       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6481       double precision contr(maxlob,-1:1)
6482       logical mixed
6483 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6484         escloc_i=0.0D0
6485         do j=1,3
6486           dersc(j)=0.0D0
6487           if (mixed) ddersc(j)=0.0d0
6488         enddo
6489         x3=x(3)
6490
6491 C Because of periodicity of the dependence of the SC energy in omega we have
6492 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6493 C To avoid underflows, first compute & store the exponents.
6494
6495         do iii=-1,1
6496
6497           x(3)=x3+iii*dwapi
6498
6499           do j=1,nlobit
6500             do k=1,3
6501               z(k)=x(k)-censc(k,j,it)
6502             enddo
6503             do k=1,3
6504               Axk=0.0D0
6505               do l=1,3
6506                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6507               enddo
6508               Ax(k,j,iii)=Axk
6509             enddo
6510             expfac=0.0D0
6511             do k=1,3
6512               expfac=expfac+Ax(k,j,iii)*z(k)
6513             enddo
6514             contr(j,iii)=expfac
6515           enddo ! j
6516
6517         enddo ! iii
6518
6519         x(3)=x3
6520 C As in the case of ebend, we want to avoid underflows in exponentiation and
6521 C subsequent NaNs and INFs in energy calculation.
6522 C Find the largest exponent
6523         emin=contr(1,-1)
6524         do iii=-1,1
6525           do j=1,nlobit
6526             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6527           enddo
6528         enddo
6529         emin=0.5D0*emin
6530 cd      print *,'it=',it,' emin=',emin
6531
6532 C Compute the contribution to SC energy and derivatives
6533         do iii=-1,1
6534
6535           do j=1,nlobit
6536             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6537 cd          print *,'j=',j,' expfac=',expfac
6538             escloc_i=escloc_i+expfac
6539             do k=1,3
6540               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6541             enddo
6542             if (mixed) then
6543               do k=1,3,2
6544                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6545      &            +gaussc(k,2,j,it))*expfac
6546               enddo
6547             endif
6548           enddo
6549
6550         enddo ! iii
6551
6552         dersc(1)=dersc(1)/cos(theti)**2
6553         ddersc(1)=ddersc(1)/cos(theti)**2
6554         ddersc(3)=ddersc(3)
6555
6556         escloci=-(dlog(escloc_i)-emin)
6557         do j=1,3
6558           dersc(j)=dersc(j)/escloc_i
6559         enddo
6560         if (mixed) then
6561           do j=1,3,2
6562             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6563           enddo
6564         endif
6565       return
6566       end
6567 C------------------------------------------------------------------------------
6568       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6569       implicit real*8 (a-h,o-z)
6570       include 'DIMENSIONS'
6571       include 'COMMON.GEO'
6572       include 'COMMON.LOCAL'
6573       include 'COMMON.IOUNITS'
6574       common /sccalc/ time11,time12,time112,theti,it,nlobit
6575       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6576       double precision contr(maxlob)
6577       logical mixed
6578
6579       escloc_i=0.0D0
6580
6581       do j=1,3
6582         dersc(j)=0.0D0
6583       enddo
6584
6585       do j=1,nlobit
6586         do k=1,2
6587           z(k)=x(k)-censc(k,j,it)
6588         enddo
6589         z(3)=dwapi
6590         do k=1,3
6591           Axk=0.0D0
6592           do l=1,3
6593             Axk=Axk+gaussc(l,k,j,it)*z(l)
6594           enddo
6595           Ax(k,j)=Axk
6596         enddo
6597         expfac=0.0D0
6598         do k=1,3
6599           expfac=expfac+Ax(k,j)*z(k)
6600         enddo
6601         contr(j)=expfac
6602       enddo ! j
6603
6604 C As in the case of ebend, we want to avoid underflows in exponentiation and
6605 C subsequent NaNs and INFs in energy calculation.
6606 C Find the largest exponent
6607       emin=contr(1)
6608       do j=1,nlobit
6609         if (emin.gt.contr(j)) emin=contr(j)
6610       enddo
6611       emin=0.5D0*emin
6612
6613 C Compute the contribution to SC energy and derivatives
6614
6615       dersc12=0.0d0
6616       do j=1,nlobit
6617         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6618         escloc_i=escloc_i+expfac
6619         do k=1,2
6620           dersc(k)=dersc(k)+Ax(k,j)*expfac
6621         enddo
6622         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6623      &            +gaussc(1,2,j,it))*expfac
6624         dersc(3)=0.0d0
6625       enddo
6626
6627       dersc(1)=dersc(1)/cos(theti)**2
6628       dersc12=dersc12/cos(theti)**2
6629       escloci=-(dlog(escloc_i)-emin)
6630       do j=1,2
6631         dersc(j)=dersc(j)/escloc_i
6632       enddo
6633       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6634       return
6635       end
6636 #else
6637 c----------------------------------------------------------------------------------
6638       subroutine esc(escloc)
6639 C Calculate the local energy of a side chain and its derivatives in the
6640 C corresponding virtual-bond valence angles THETA and the spherical angles
6641 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6642 C added by Urszula Kozlowska. 07/11/2007
6643 C
6644       implicit real*8 (a-h,o-z)
6645       include 'DIMENSIONS'
6646       include 'DIMENSIONS.ZSCOPT'
6647       include 'COMMON.GEO'
6648       include 'COMMON.LOCAL'
6649       include 'COMMON.VAR'
6650       include 'COMMON.SCROT'
6651       include 'COMMON.INTERACT'
6652       include 'COMMON.DERIV'
6653       include 'COMMON.CHAIN'
6654       include 'COMMON.IOUNITS'
6655       include 'COMMON.NAMES'
6656       include 'COMMON.FFIELD'
6657       include 'COMMON.CONTROL'
6658       include 'COMMON.VECTORS'
6659       double precision x_prime(3),y_prime(3),z_prime(3)
6660      &    , sumene,dsc_i,dp2_i,x(65),
6661      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6662      &    de_dxx,de_dyy,de_dzz,de_dt
6663       double precision s1_t,s1_6_t,s2_t,s2_6_t
6664       double precision
6665      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6666      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6667      & dt_dCi(3),dt_dCi1(3)
6668       common /sccalc/ time11,time12,time112,theti,it,nlobit
6669       delta=0.02d0*pi
6670       escloc=0.0D0
6671       do i=loc_start,loc_end
6672         if (itype(i).eq.ntyp1) cycle
6673         costtab(i+1) =dcos(theta(i+1))
6674         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6675         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6676         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6677         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6678         cosfac=dsqrt(cosfac2)
6679         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6680         sinfac=dsqrt(sinfac2)
6681         it=iabs(itype(i))
6682         if (it.eq.10) goto 1
6683 c
6684 C  Compute the axes of tghe local cartesian coordinates system; store in
6685 c   x_prime, y_prime and z_prime
6686 c
6687         do j=1,3
6688           x_prime(j) = 0.00
6689           y_prime(j) = 0.00
6690           z_prime(j) = 0.00
6691         enddo
6692 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6693 C     &   dc_norm(3,i+nres)
6694         do j = 1,3
6695           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6696           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6697         enddo
6698         do j = 1,3
6699           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6700         enddo
6701 c       write (2,*) "i",i
6702 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6703 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6704 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6705 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6706 c      & " xy",scalar(x_prime(1),y_prime(1)),
6707 c      & " xz",scalar(x_prime(1),z_prime(1)),
6708 c      & " yy",scalar(y_prime(1),y_prime(1)),
6709 c      & " yz",scalar(y_prime(1),z_prime(1)),
6710 c      & " zz",scalar(z_prime(1),z_prime(1))
6711 c
6712 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6713 C to local coordinate system. Store in xx, yy, zz.
6714 c
6715         xx=0.0d0
6716         yy=0.0d0
6717         zz=0.0d0
6718         do j = 1,3
6719           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6720           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6721           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6722         enddo
6723
6724         xxtab(i)=xx
6725         yytab(i)=yy
6726         zztab(i)=zz
6727 C
6728 C Compute the energy of the ith side cbain
6729 C
6730 c        write (2,*) "xx",xx," yy",yy," zz",zz
6731         it=iabs(itype(i))
6732         do j = 1,65
6733           x(j) = sc_parmin(j,it)
6734         enddo
6735 #ifdef CHECK_COORD
6736 Cc diagnostics - remove later
6737         xx1 = dcos(alph(2))
6738         yy1 = dsin(alph(2))*dcos(omeg(2))
6739         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6740         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6741      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6742      &    xx1,yy1,zz1
6743 C,"  --- ", xx_w,yy_w,zz_w
6744 c end diagnostics
6745 #endif
6746         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6747      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6748      &   + x(10)*yy*zz
6749         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6750      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6751      & + x(20)*yy*zz
6752         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6753      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6754      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6755      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6756      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6757      &  +x(40)*xx*yy*zz
6758         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6759      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6760      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6761      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6762      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6763      &  +x(60)*xx*yy*zz
6764         dsc_i   = 0.743d0+x(61)
6765         dp2_i   = 1.9d0+x(62)
6766         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6767      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6768         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6769      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6770         s1=(1+x(63))/(0.1d0 + dscp1)
6771         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6772         s2=(1+x(65))/(0.1d0 + dscp2)
6773         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6774         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6775      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6776 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6777 c     &   sumene4,
6778 c     &   dscp1,dscp2,sumene
6779 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6780         escloc = escloc + sumene
6781 c        write (2,*) "escloc",escloc
6782 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6783 c     &  zz,xx,yy
6784         if (.not. calc_grad) goto 1
6785 #ifdef DEBUG
6786 C
6787 C This section to check the numerical derivatives of the energy of ith side
6788 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6789 C #define DEBUG in the code to turn it on.
6790 C
6791         write (2,*) "sumene               =",sumene
6792         aincr=1.0d-7
6793         xxsave=xx
6794         xx=xx+aincr
6795         write (2,*) xx,yy,zz
6796         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6797         de_dxx_num=(sumenep-sumene)/aincr
6798         xx=xxsave
6799         write (2,*) "xx+ sumene from enesc=",sumenep
6800         yysave=yy
6801         yy=yy+aincr
6802         write (2,*) xx,yy,zz
6803         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6804         de_dyy_num=(sumenep-sumene)/aincr
6805         yy=yysave
6806         write (2,*) "yy+ sumene from enesc=",sumenep
6807         zzsave=zz
6808         zz=zz+aincr
6809         write (2,*) xx,yy,zz
6810         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6811         de_dzz_num=(sumenep-sumene)/aincr
6812         zz=zzsave
6813         write (2,*) "zz+ sumene from enesc=",sumenep
6814         costsave=cost2tab(i+1)
6815         sintsave=sint2tab(i+1)
6816         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6817         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6818         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6819         de_dt_num=(sumenep-sumene)/aincr
6820         write (2,*) " t+ sumene from enesc=",sumenep
6821         cost2tab(i+1)=costsave
6822         sint2tab(i+1)=sintsave
6823 C End of diagnostics section.
6824 #endif
6825 C
6826 C Compute the gradient of esc
6827 C
6828         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6829         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6830         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6831         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6832         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6833         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6834         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6835         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6836         pom1=(sumene3*sint2tab(i+1)+sumene1)
6837      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6838         pom2=(sumene4*cost2tab(i+1)+sumene2)
6839      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6840         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6841         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6842      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6843      &  +x(40)*yy*zz
6844         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6845         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6846      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6847      &  +x(60)*yy*zz
6848         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6849      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6850      &        +(pom1+pom2)*pom_dx
6851 #ifdef DEBUG
6852         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6853 #endif
6854 C
6855         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6856         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6857      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6858      &  +x(40)*xx*zz
6859         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6860         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6861      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6862      &  +x(59)*zz**2 +x(60)*xx*zz
6863         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6864      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6865      &        +(pom1-pom2)*pom_dy
6866 #ifdef DEBUG
6867         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6868 #endif
6869 C
6870         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6871      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6872      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6873      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6874      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6875      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6876      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6877      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6878 #ifdef DEBUG
6879         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6880 #endif
6881 C
6882         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6883      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6884      &  +pom1*pom_dt1+pom2*pom_dt2
6885 #ifdef DEBUG
6886         write(2,*), "de_dt = ", de_dt,de_dt_num
6887 #endif
6888 c
6889 C
6890        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6891        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6892        cosfac2xx=cosfac2*xx
6893        sinfac2yy=sinfac2*yy
6894        do k = 1,3
6895          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6896      &      vbld_inv(i+1)
6897          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6898      &      vbld_inv(i)
6899          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6900          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6901 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6902 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6903 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6904 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6905          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6906          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6907          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6908          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6909          dZZ_Ci1(k)=0.0d0
6910          dZZ_Ci(k)=0.0d0
6911          do j=1,3
6912            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6913      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6914            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6915      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6916          enddo
6917
6918          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6919          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6920          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6921 c
6922          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6923          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6924        enddo
6925
6926        do k=1,3
6927          dXX_Ctab(k,i)=dXX_Ci(k)
6928          dXX_C1tab(k,i)=dXX_Ci1(k)
6929          dYY_Ctab(k,i)=dYY_Ci(k)
6930          dYY_C1tab(k,i)=dYY_Ci1(k)
6931          dZZ_Ctab(k,i)=dZZ_Ci(k)
6932          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6933          dXX_XYZtab(k,i)=dXX_XYZ(k)
6934          dYY_XYZtab(k,i)=dYY_XYZ(k)
6935          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6936        enddo
6937
6938        do k = 1,3
6939 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6940 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6941 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6942 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6943 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6944 c     &    dt_dci(k)
6945 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6946 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6947          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6948      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6949          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6950      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6951          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6952      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6953        enddo
6954 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6955 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6956
6957 C to check gradient call subroutine check_grad
6958
6959     1 continue
6960       enddo
6961       return
6962       end
6963 #endif
6964 c------------------------------------------------------------------------------
6965       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6966 C
6967 C This procedure calculates two-body contact function g(rij) and its derivative:
6968 C
6969 C           eps0ij                                     !       x < -1
6970 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6971 C            0                                         !       x > 1
6972 C
6973 C where x=(rij-r0ij)/delta
6974 C
6975 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6976 C
6977       implicit none
6978       double precision rij,r0ij,eps0ij,fcont,fprimcont
6979       double precision x,x2,x4,delta
6980 c     delta=0.02D0*r0ij
6981 c      delta=0.2D0*r0ij
6982       x=(rij-r0ij)/delta
6983       if (x.lt.-1.0D0) then
6984         fcont=eps0ij
6985         fprimcont=0.0D0
6986       else if (x.le.1.0D0) then
6987         x2=x*x
6988         x4=x2*x2
6989         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6990         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6991       else
6992         fcont=0.0D0
6993         fprimcont=0.0D0
6994       endif
6995       return
6996       end
6997 c------------------------------------------------------------------------------
6998       subroutine splinthet(theti,delta,ss,ssder)
6999       implicit real*8 (a-h,o-z)
7000       include 'DIMENSIONS'
7001       include 'DIMENSIONS.ZSCOPT'
7002       include 'COMMON.VAR'
7003       include 'COMMON.GEO'
7004       thetup=pi-delta
7005       thetlow=delta
7006       if (theti.gt.pipol) then
7007         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7008       else
7009         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7010         ssder=-ssder
7011       endif
7012       return
7013       end
7014 c------------------------------------------------------------------------------
7015       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7016       implicit none
7017       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7018       double precision ksi,ksi2,ksi3,a1,a2,a3
7019       a1=fprim0*delta/(f1-f0)
7020       a2=3.0d0-2.0d0*a1
7021       a3=a1-2.0d0
7022       ksi=(x-x0)/delta
7023       ksi2=ksi*ksi
7024       ksi3=ksi2*ksi
7025       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7026       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7027       return
7028       end
7029 c------------------------------------------------------------------------------
7030       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7031       implicit none
7032       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7033       double precision ksi,ksi2,ksi3,a1,a2,a3
7034       ksi=(x-x0)/delta
7035       ksi2=ksi*ksi
7036       ksi3=ksi2*ksi
7037       a1=fprim0x*delta
7038       a2=3*(f1x-f0x)-2*fprim0x*delta
7039       a3=fprim0x*delta-2*(f1x-f0x)
7040       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7041       return
7042       end
7043 C-----------------------------------------------------------------------------
7044 #ifdef CRYST_TOR
7045 C-----------------------------------------------------------------------------
7046       subroutine etor(etors)
7047       implicit real*8 (a-h,o-z)
7048       include 'DIMENSIONS'
7049       include 'DIMENSIONS.ZSCOPT'
7050       include 'COMMON.VAR'
7051       include 'COMMON.GEO'
7052       include 'COMMON.LOCAL'
7053       include 'COMMON.TORSION'
7054       include 'COMMON.INTERACT'
7055       include 'COMMON.DERIV'
7056       include 'COMMON.CHAIN'
7057       include 'COMMON.NAMES'
7058       include 'COMMON.IOUNITS'
7059       include 'COMMON.FFIELD'
7060       include 'COMMON.TORCNSTR'
7061       logical lprn
7062 C Set lprn=.true. for debugging
7063       lprn=.false.
7064 c      lprn=.true.
7065       etors=0.0D0
7066       do i=iphi_start,iphi_end
7067         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
7068      &      .or. itype(i).eq.ntyp1) cycle
7069         itori=itortyp(itype(i-2))
7070         itori1=itortyp(itype(i-1))
7071         phii=phi(i)
7072         gloci=0.0D0
7073 C Proline-Proline pair is a special case...
7074         if (itori.eq.3 .and. itori1.eq.3) then
7075           if (phii.gt.-dwapi3) then
7076             cosphi=dcos(3*phii)
7077             fac=1.0D0/(1.0D0-cosphi)
7078             etorsi=v1(1,3,3)*fac
7079             etorsi=etorsi+etorsi
7080             etors=etors+etorsi-v1(1,3,3)
7081             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7082           endif
7083           do j=1,3
7084             v1ij=v1(j+1,itori,itori1)
7085             v2ij=v2(j+1,itori,itori1)
7086             cosphi=dcos(j*phii)
7087             sinphi=dsin(j*phii)
7088             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7089             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7090           enddo
7091         else
7092           do j=1,nterm_old
7093             v1ij=v1(j,itori,itori1)
7094             v2ij=v2(j,itori,itori1)
7095             cosphi=dcos(j*phii)
7096             sinphi=dsin(j*phii)
7097             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7098             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7099           enddo
7100         endif
7101         if (lprn)
7102      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7103      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7104      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7105         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7106 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7107       enddo
7108       return
7109       end
7110 c------------------------------------------------------------------------------
7111 #else
7112       subroutine etor(etors)
7113       implicit real*8 (a-h,o-z)
7114       include 'DIMENSIONS'
7115       include 'DIMENSIONS.ZSCOPT'
7116       include 'COMMON.VAR'
7117       include 'COMMON.GEO'
7118       include 'COMMON.LOCAL'
7119       include 'COMMON.TORSION'
7120       include 'COMMON.INTERACT'
7121       include 'COMMON.DERIV'
7122       include 'COMMON.CHAIN'
7123       include 'COMMON.NAMES'
7124       include 'COMMON.IOUNITS'
7125       include 'COMMON.FFIELD'
7126       include 'COMMON.TORCNSTR'
7127       include 'COMMON.WEIGHTS'
7128       include 'COMMON.WEIGHTDER'
7129       logical lprn
7130 C Set lprn=.true. for debugging
7131       lprn=.false.
7132 c      lprn=.true.
7133       etors=0.0D0
7134       do iblock=1,2
7135       do i=-ntyp+1,ntyp-1
7136         do j=-ntyp+1,ntyp-1
7137           do k=0,3
7138             do l=0,2*maxterm
7139               etor_temp(l,k,j,i,iblock)=0.0d0
7140             enddo
7141           enddo
7142         enddo
7143       enddo
7144       enddo
7145       do i=iphi_start,iphi_end
7146         if (i.le.2) cycle
7147         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7148      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7149         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
7150         if (iabs(itype(i)).eq.20) then
7151           iblock=2
7152         else
7153           iblock=1
7154         endif
7155         itori=itortyp(itype(i-2))
7156         itori1=itortyp(itype(i-1))
7157         weitori=weitor(0,itori,itori1,iblock)
7158         phii=phi(i)
7159         gloci=0.0D0
7160         etori=0.0d0
7161 C Regular cosine and sine terms
7162         do j=1,nterm(itori,itori1,iblock)
7163           v1ij=v1(j,itori,itori1,iblock)
7164           v2ij=v2(j,itori,itori1,iblock)
7165           cosphi=dcos(j*phii)
7166           sinphi=dsin(j*phii)
7167           etori=etori+v1ij*cosphi+v2ij*sinphi
7168           etor_temp(j,0,itori,itori1,iblock)=
7169      &      etor_temp(j,0,itori,itori1,iblock)+cosphi*ww(13)
7170           etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)=
7171      &    etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)+
7172      &      sinphi*ww(13)
7173           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7174         enddo
7175 C Lorentz terms
7176 C                         v1
7177 C  E = SUM ----------------------------------- - v1
7178 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7179 C
7180         cosphi=dcos(0.5d0*phii)
7181         sinphi=dsin(0.5d0*phii)
7182         do j=1,nlor(itori,itori1,iblock)
7183           vl1ij=vlor1(j,itori,itori1)
7184           vl2ij=vlor2(j,itori,itori1)
7185           vl3ij=vlor3(j,itori,itori1)
7186           pom=vl2ij*cosphi+vl3ij*sinphi
7187           pom1=1.0d0/(pom*pom+1.0d0)
7188           etori=etori+vl1ij*pom1
7189           pom=-pom*pom1*pom1
7190           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7191         enddo
7192 C Subtract the constant term
7193         etors=etors+(etori-v0(itori,itori1,iblock))*weitori
7194         etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)+
7195      &    (etori-v0(itori,itori1,iblock))*ww(13)
7196
7197         if (lprn) then
7198         write (iout,'(2(a3,2x,i3,2x),2i3,8f8.3/26x,6f8.3/)')
7199      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7200      &  weitori,v0(itori,itori1,iblock)*weitori,
7201      &  (v1(j,itori,itori1,iblock)*weitori,
7202      &  j=1,6),(v2(j,itori,itori1,iblock)*weitori,j=1,6)
7203         write (iout,*) "typ",itori,iloctyp(itori),itori1,
7204      &    iloctyp(itori1)," etor_temp",
7205      &    etor_temp(0,0,itori,itori1,1)
7206         call flush(iout)
7207         endif
7208         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7209 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7210  1215   continue
7211       enddo
7212       return
7213       end
7214 c----------------------------------------------------------------------------
7215       subroutine etor_d(etors_d)
7216 C 6/23/01 Compute double torsional energy
7217       implicit real*8 (a-h,o-z)
7218       include 'DIMENSIONS'
7219       include 'DIMENSIONS.ZSCOPT'
7220       include 'COMMON.VAR'
7221       include 'COMMON.GEO'
7222       include 'COMMON.LOCAL'
7223       include 'COMMON.TORSION'
7224       include 'COMMON.INTERACT'
7225       include 'COMMON.DERIV'
7226       include 'COMMON.CHAIN'
7227       include 'COMMON.NAMES'
7228       include 'COMMON.IOUNITS'
7229       include 'COMMON.FFIELD'
7230       include 'COMMON.TORCNSTR'
7231       logical lprn
7232 C Set lprn=.true. for debugging
7233       lprn=.false.
7234 c     lprn=.true.
7235       etors_d=0.0D0
7236       do i=iphi_start,iphi_end-1
7237         if (i.le.3) cycle
7238 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7239 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
7240          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7241      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7242      &  (itype(i+1).eq.ntyp1)) cycle
7243         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
7244      &     goto 1215
7245         itori=itortyp(itype(i-2))
7246         itori1=itortyp(itype(i-1))
7247         itori2=itortyp(itype(i))
7248         phii=phi(i)
7249         phii1=phi(i+1)
7250         gloci1=0.0D0
7251         gloci2=0.0D0
7252         iblock=1
7253         if (iabs(itype(i+1)).eq.20) iblock=2
7254 C Regular cosine and sine terms
7255         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7256           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7257           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7258           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7259           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7260           cosphi1=dcos(j*phii)
7261           sinphi1=dsin(j*phii)
7262           cosphi2=dcos(j*phii1)
7263           sinphi2=dsin(j*phii1)
7264           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7265      &     v2cij*cosphi2+v2sij*sinphi2
7266           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7267           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7268         enddo
7269         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7270           do l=1,k-1
7271             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7272             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7273             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7274             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7275             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7276             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7277             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7278             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7279             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7280      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7281             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7282      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7283             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7284      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7285           enddo
7286         enddo
7287         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7288         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7289  1215   continue
7290       enddo
7291       return
7292       end
7293 #endif
7294 c---------------------------------------------------------------------------
7295 C The rigorous attempt to derive energy function
7296       subroutine etor_kcc(etors)
7297       implicit real*8 (a-h,o-z)
7298       include 'DIMENSIONS'
7299       include 'DIMENSIONS.ZSCOPT'
7300       include 'COMMON.VAR'
7301       include 'COMMON.GEO'
7302       include 'COMMON.LOCAL'
7303       include 'COMMON.TORSION'
7304       include 'COMMON.INTERACT'
7305       include 'COMMON.DERIV'
7306       include 'COMMON.CHAIN'
7307       include 'COMMON.NAMES'
7308       include 'COMMON.IOUNITS'
7309       include 'COMMON.FFIELD'
7310       include 'COMMON.TORCNSTR'
7311       include 'COMMON.CONTROL'
7312       include 'COMMON.WEIGHTS'
7313       include 'COMMON.WEIGHTDER'
7314       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7315       logical lprn
7316 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7317 C Set lprn=.true. for debugging
7318       lprn=energy_dec
7319 c      lprn=.true.
7320       if (lprn) write (iout,*)"ETOR_KCC"
7321       do iblock=1,2
7322       do i=-ntyp+1,ntyp-1
7323         do j=-ntyp+1,ntyp-1
7324           do k=0,3
7325             do l=0,2*maxterm
7326               etor_temp(l,k,j,i,iblock)=0.0d0
7327             enddo
7328           enddo
7329         enddo
7330       enddo
7331       enddo
7332       do i=-ntyp+1,ntyp-1
7333         do j=-ntyp+1,ntyp-1
7334           do k=0,2*maxtor_kcc
7335             do l=1,maxval_kcc
7336               do ll=1,maxval_kcc
7337                 etor_temp_kcc(ll,l,k,j,i)=0.0d0
7338               enddo
7339             enddo
7340           enddo
7341         enddo
7342       enddo
7343       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7344       etors=0.0D0
7345       do i=iphi_start,iphi_end
7346 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7347 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7348 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7349 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7350         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7351      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7352         itori=itortyp(itype(i-2))
7353         itori1=itortyp(itype(i-1))
7354         weitori=weitor(0,itori,itori1,1)
7355         if (lprn) write (iout,*) i-2,i-2,itori,itori1,"weitor",weitori
7356         phii=phi(i)
7357         glocig=0.0D0
7358         glocit1=0.0d0
7359         glocit2=0.0d0
7360 C to avoid multiple devision by 2
7361 c        theti22=0.5d0*theta(i)
7362 C theta 12 is the theta_1 /2
7363 C theta 22 is theta_2 /2
7364 c        theti12=0.5d0*theta(i-1)
7365 C and appropriate sinus function
7366         sinthet1=dsin(theta(i-1))
7367         sinthet2=dsin(theta(i))
7368         costhet1=dcos(theta(i-1))
7369         costhet2=dcos(theta(i))
7370 C to speed up lets store its mutliplication
7371         sint1t2=sinthet2*sinthet1
7372         sint1t2n=1.0d0
7373 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7374 C +d_n*sin(n*gamma)) *
7375 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7376 C we have two sum 1) Non-Chebyshev which is with n and gamma
7377         nval=nterm_kcc_Tb(itori,itori1)
7378         c1(0)=0.0d0
7379         c2(0)=0.0d0
7380         c1(1)=1.0d0
7381         c2(1)=1.0d0
7382         do j=2,nval
7383           c1(j)=c1(j-1)*costhet1
7384           c2(j)=c2(j-1)*costhet2
7385         enddo
7386         etori=0.0d0
7387         do j=1,nterm_kcc(itori,itori1)
7388           cosphi=dcos(j*phii)
7389           sinphi=dsin(j*phii)
7390           sint1t2n1=sint1t2n
7391           sint1t2n=sint1t2n*sint1t2
7392           sumvalc=0.0d0
7393           gradvalct1=0.0d0
7394           gradvalct2=0.0d0
7395           do k=1,nval
7396             do l=1,nval
7397               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7398               etor_temp_kcc(l,k,j,itori,itori1)=
7399      &           etor_temp_kcc(l,k,j,itori,itori1)+
7400      &           c1(k)*c2(l)*sint1t2n*cosphi*ww(13)
7401               gradvalct1=gradvalct1+
7402      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7403               gradvalct2=gradvalct2+
7404      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7405             enddo
7406           enddo
7407           gradvalct1=-gradvalct1*sinthet1
7408           gradvalct2=-gradvalct2*sinthet2
7409           sumvals=0.0d0
7410           gradvalst1=0.0d0
7411           gradvalst2=0.0d0
7412           do k=1,nval
7413             do l=1,nval
7414               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7415               etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)=
7416      &        etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)+
7417      &           c1(k)*c2(l)*sint1t2n*sinphi*ww(13)
7418               gradvalst1=gradvalst1+
7419      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7420               gradvalst2=gradvalst2+
7421      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7422             enddo
7423           enddo
7424           gradvalst1=-gradvalst1*sinthet1
7425           gradvalst2=-gradvalst2*sinthet2
7426           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7427           etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)
7428      &     +sint1t2n*(sumvalc*cosphi+sumvals*sinphi)*ww(13)
7429 C glocig is the gradient local i site in gamma
7430           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7431 C now gradient over theta_1
7432           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7433      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7434           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7435      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7436         enddo ! j
7437         etors=etors+etori*weitori
7438 C derivative over gamma
7439         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7440 C derivative over theta1
7441         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7442 C now derivative over theta2
7443         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7444         if (lprn)
7445      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7446      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7447       enddo
7448       return
7449       end
7450 c---------------------------------------------------------------------------------------------
7451       subroutine etor_constr(edihcnstr)
7452       implicit real*8 (a-h,o-z)
7453       include 'DIMENSIONS'
7454       include 'DIMENSIONS.ZSCOPT'
7455       include 'COMMON.VAR'
7456       include 'COMMON.GEO'
7457       include 'COMMON.LOCAL'
7458       include 'COMMON.TORSION'
7459       include 'COMMON.INTERACT'
7460       include 'COMMON.DERIV'
7461       include 'COMMON.CHAIN'
7462       include 'COMMON.NAMES'
7463       include 'COMMON.IOUNITS'
7464       include 'COMMON.FFIELD'
7465       include 'COMMON.TORCNSTR'
7466       include 'COMMON.CONTROL'
7467 ! 6/20/98 - dihedral angle constraints
7468       edihcnstr=0.0d0
7469 c      do i=1,ndih_constr
7470 c      write (iout,*) "idihconstr_start",idihconstr_start,
7471 c     &  " idihconstr_end",idihconstr_end
7472       do i=idihconstr_start,idihconstr_end
7473         itori=idih_constr(i)
7474         phii=phi(itori)
7475         difi=pinorm(phii-phi0(i))
7476         if (difi.gt.drange(i)) then
7477           difi=difi-drange(i)
7478           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7479           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7480         else if (difi.lt.-drange(i)) then
7481           difi=difi+drange(i)
7482           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7483           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7484         else
7485           difi=0.0
7486         endif
7487       enddo
7488       return
7489       end
7490 c----------------------------------------------------------------------------
7491 C The rigorous attempt to derive energy function
7492       subroutine ebend_kcc(etheta)
7493
7494       implicit real*8 (a-h,o-z)
7495       include 'DIMENSIONS'
7496       include 'DIMENSIONS.ZSCOPT'
7497       include 'COMMON.VAR'
7498       include 'COMMON.GEO'
7499       include 'COMMON.LOCAL'
7500       include 'COMMON.TORSION'
7501       include 'COMMON.INTERACT'
7502       include 'COMMON.DERIV'
7503       include 'COMMON.CHAIN'
7504       include 'COMMON.NAMES'
7505       include 'COMMON.IOUNITS'
7506       include 'COMMON.FFIELD'
7507       include 'COMMON.TORCNSTR'
7508       include 'COMMON.CONTROL'
7509       include 'COMMON.WEIGHTDER'
7510       logical lprn
7511       double precision thybt1(maxang_kcc)
7512 C Set lprn=.true. for debugging
7513       lprn=energy_dec
7514 c     lprn=.true.
7515 C      print *,"wchodze kcc"
7516       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7517       do i=0,ntyp
7518         do j=1,maxang_kcc
7519           ebend_temp_kcc(j,i)=0.0d0
7520         enddo
7521       enddo
7522       etheta=0.0D0
7523       do i=ithet_start,ithet_end
7524 c        print *,i,itype(i-1),itype(i),itype(i-2)
7525         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7526      &  .or.itype(i).eq.ntyp1) cycle
7527         iti=iabs(itortyp(itype(i-1)))
7528         sinthet=dsin(theta(i))
7529         costhet=dcos(theta(i))
7530         do j=1,nbend_kcc_Tb(iti)
7531           thybt1(j)=v1bend_chyb(j,iti)
7532           ebend_temp_kcc(j,iti)=ebend_temp_kcc(j,iti)+dcos(j*theta(i))
7533         enddo
7534         sumth1thyb=v1bend_chyb(0,iti)+
7535      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7536         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7537      &    sumth1thyb
7538         ihelp=nbend_kcc_Tb(iti)-1
7539         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7540         etheta=etheta+sumth1thyb
7541 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7542         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7543       enddo
7544       return
7545       end
7546 c-------------------------------------------------------------------------------------
7547       subroutine etheta_constr(ethetacnstr)
7548
7549       implicit real*8 (a-h,o-z)
7550       include 'DIMENSIONS'
7551       include 'DIMENSIONS.ZSCOPT'
7552       include 'COMMON.VAR'
7553       include 'COMMON.GEO'
7554       include 'COMMON.LOCAL'
7555       include 'COMMON.TORSION'
7556       include 'COMMON.INTERACT'
7557       include 'COMMON.DERIV'
7558       include 'COMMON.CHAIN'
7559       include 'COMMON.NAMES'
7560       include 'COMMON.IOUNITS'
7561       include 'COMMON.FFIELD'
7562       include 'COMMON.TORCNSTR'
7563       include 'COMMON.CONTROL'
7564       ethetacnstr=0.0d0
7565 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7566       do i=ithetaconstr_start,ithetaconstr_end
7567         itheta=itheta_constr(i)
7568         thetiii=theta(itheta)
7569         difi=pinorm(thetiii-theta_constr0(i))
7570         if (difi.gt.theta_drange(i)) then
7571           difi=difi-theta_drange(i)
7572           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7573           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7574      &    +for_thet_constr(i)*difi**3
7575         else if (difi.lt.-drange(i)) then
7576           difi=difi+drange(i)
7577           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7578           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7579      &    +for_thet_constr(i)*difi**3
7580         else
7581           difi=0.0
7582         endif
7583        if (energy_dec) then
7584         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7585      &    i,itheta,rad2deg*thetiii,
7586      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7587      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7588      &    gloc(itheta+nphi-2,icg)
7589         endif
7590       enddo
7591       return
7592       end
7593 c------------------------------------------------------------------------------
7594       subroutine eback_sc_corr(esccor)
7595 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7596 c        conformational states; temporarily implemented as differences
7597 c        between UNRES torsional potentials (dependent on three types of
7598 c        residues) and the torsional potentials dependent on all 20 types
7599 c        of residues computed from AM1 energy surfaces of terminally-blocked
7600 c        amino-acid residues.
7601       implicit real*8 (a-h,o-z)
7602       include 'DIMENSIONS'
7603       include 'DIMENSIONS.ZSCOPT'
7604       include 'COMMON.VAR'
7605       include 'COMMON.GEO'
7606       include 'COMMON.LOCAL'
7607       include 'COMMON.TORSION'
7608       include 'COMMON.SCCOR'
7609       include 'COMMON.INTERACT'
7610       include 'COMMON.DERIV'
7611       include 'COMMON.CHAIN'
7612       include 'COMMON.NAMES'
7613       include 'COMMON.IOUNITS'
7614       include 'COMMON.FFIELD'
7615       include 'COMMON.CONTROL'
7616       logical lprn
7617 C Set lprn=.true. for debugging
7618       lprn=.false.
7619 c      lprn=.true.
7620 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7621       esccor=0.0D0
7622       do i=itau_start,itau_end
7623         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7624         esccor_ii=0.0D0
7625         isccori=isccortyp(itype(i-2))
7626         isccori1=isccortyp(itype(i-1))
7627         phii=phi(i)
7628         do intertyp=1,3 !intertyp
7629 cc Added 09 May 2012 (Adasko)
7630 cc  Intertyp means interaction type of backbone mainchain correlation:
7631 c   1 = SC...Ca...Ca...Ca
7632 c   2 = Ca...Ca...Ca...SC
7633 c   3 = SC...Ca...Ca...SCi
7634         gloci=0.0D0
7635         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7636      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7637      &      (itype(i-1).eq.ntyp1)))
7638      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7639      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7640      &     .or.(itype(i).eq.ntyp1)))
7641      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7642      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7643      &      (itype(i-3).eq.ntyp1)))) cycle
7644         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7645         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7646      & cycle
7647        do j=1,nterm_sccor(isccori,isccori1)
7648           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7649           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7650           cosphi=dcos(j*tauangle(intertyp,i))
7651           sinphi=dsin(j*tauangle(intertyp,i))
7652            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7653            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7654          enddo
7655 C      write (iout,*)"EBACK_SC_COR",esccor,i
7656 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7657 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7658 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7659         if (lprn)
7660      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7661      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7662      &  (v1sccor(j,1,itori,itori1),j=1,6)
7663      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7664 c        gsccor_loc(i-3)=gloci
7665        enddo !intertyp
7666       enddo
7667       return
7668       end
7669 c------------------------------------------------------------------------------
7670       subroutine multibody(ecorr)
7671 C This subroutine calculates multi-body contributions to energy following
7672 C the idea of Skolnick et al. If side chains I and J make a contact and
7673 C at the same time side chains I+1 and J+1 make a contact, an extra
7674 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7675       implicit real*8 (a-h,o-z)
7676       include 'DIMENSIONS'
7677       include 'DIMENSIONS.ZSCOPT'
7678       include 'COMMON.IOUNITS'
7679       include 'COMMON.DERIV'
7680       include 'COMMON.INTERACT'
7681       include 'COMMON.CONTACTS'
7682       double precision gx(3),gx1(3)
7683       logical lprn
7684
7685 C Set lprn=.true. for debugging
7686       lprn=.false.
7687
7688       if (lprn) then
7689         write (iout,'(a)') 'Contact function values:'
7690         do i=nnt,nct-2
7691           write (iout,'(i2,20(1x,i2,f10.5))')
7692      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7693         enddo
7694       endif
7695       ecorr=0.0D0
7696       do i=nnt,nct
7697         do j=1,3
7698           gradcorr(j,i)=0.0D0
7699           gradxorr(j,i)=0.0D0
7700         enddo
7701       enddo
7702       do i=nnt,nct-2
7703
7704         DO ISHIFT = 3,4
7705
7706         i1=i+ishift
7707         num_conti=num_cont(i)
7708         num_conti1=num_cont(i1)
7709         do jj=1,num_conti
7710           j=jcont(jj,i)
7711           do kk=1,num_conti1
7712             j1=jcont(kk,i1)
7713             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7714 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7715 cd   &                   ' ishift=',ishift
7716 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7717 C The system gains extra energy.
7718               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7719             endif   ! j1==j+-ishift
7720           enddo     ! kk
7721         enddo       ! jj
7722
7723         ENDDO ! ISHIFT
7724
7725       enddo         ! i
7726       return
7727       end
7728 c------------------------------------------------------------------------------
7729       double precision function esccorr(i,j,k,l,jj,kk)
7730       implicit real*8 (a-h,o-z)
7731       include 'DIMENSIONS'
7732       include 'DIMENSIONS.ZSCOPT'
7733       include 'COMMON.IOUNITS'
7734       include 'COMMON.DERIV'
7735       include 'COMMON.INTERACT'
7736       include 'COMMON.CONTACTS'
7737       double precision gx(3),gx1(3)
7738       logical lprn
7739       lprn=.false.
7740       eij=facont(jj,i)
7741       ekl=facont(kk,k)
7742 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7743 C Calculate the multi-body contribution to energy.
7744 C Calculate multi-body contributions to the gradient.
7745 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7746 cd   & k,l,(gacont(m,kk,k),m=1,3)
7747       do m=1,3
7748         gx(m) =ekl*gacont(m,jj,i)
7749         gx1(m)=eij*gacont(m,kk,k)
7750         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7751         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7752         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7753         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7754       enddo
7755       do m=i,j-1
7756         do ll=1,3
7757           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7758         enddo
7759       enddo
7760       do m=k,l-1
7761         do ll=1,3
7762           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7763         enddo
7764       enddo
7765       esccorr=-eij*ekl
7766       return
7767       end
7768 c------------------------------------------------------------------------------
7769       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7770 C This subroutine calculates multi-body contributions to hydrogen-bonding
7771       implicit real*8 (a-h,o-z)
7772       include 'DIMENSIONS'
7773       include 'DIMENSIONS.ZSCOPT'
7774       include 'COMMON.IOUNITS'
7775       include 'COMMON.FFIELD'
7776       include 'COMMON.DERIV'
7777       include 'COMMON.INTERACT'
7778       include 'COMMON.CONTACTS'
7779       double precision gx(3),gx1(3)
7780       logical lprn,ldone
7781
7782 C Set lprn=.true. for debugging
7783       lprn=.false.
7784       if (lprn) then
7785         write (iout,'(a)') 'Contact function values:'
7786         do i=nnt,nct-2
7787           write (iout,'(2i3,50(1x,i2,f5.2))')
7788      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7789      &    j=1,num_cont_hb(i))
7790         enddo
7791       endif
7792       ecorr=0.0D0
7793 C Remove the loop below after debugging !!!
7794       do i=nnt,nct
7795         do j=1,3
7796           gradcorr(j,i)=0.0D0
7797           gradxorr(j,i)=0.0D0
7798         enddo
7799       enddo
7800 C Calculate the local-electrostatic correlation terms
7801       do i=iatel_s,iatel_e+1
7802         i1=i+1
7803         num_conti=num_cont_hb(i)
7804         num_conti1=num_cont_hb(i+1)
7805         do jj=1,num_conti
7806           j=jcont_hb(jj,i)
7807           do kk=1,num_conti1
7808             j1=jcont_hb(kk,i1)
7809 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7810 c     &         ' jj=',jj,' kk=',kk
7811             if (j1.eq.j+1 .or. j1.eq.j-1) then
7812 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7813 C The system gains extra energy.
7814               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7815               n_corr=n_corr+1
7816             else if (j1.eq.j) then
7817 C Contacts I-J and I-(J+1) occur simultaneously.
7818 C The system loses extra energy.
7819 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7820             endif
7821           enddo ! kk
7822           do kk=1,num_conti
7823             j1=jcont_hb(kk,i)
7824 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7825 c    &         ' jj=',jj,' kk=',kk
7826             if (j1.eq.j+1) then
7827 C Contacts I-J and (I+1)-J occur simultaneously.
7828 C The system loses extra energy.
7829 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7830             endif ! j1==j+1
7831           enddo ! kk
7832         enddo ! jj
7833       enddo ! i
7834       return
7835       end
7836 c------------------------------------------------------------------------------
7837       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7838      &  n_corr1)
7839 C This subroutine calculates multi-body contributions to hydrogen-bonding
7840       implicit real*8 (a-h,o-z)
7841       include 'DIMENSIONS'
7842       include 'DIMENSIONS.ZSCOPT'
7843       include 'COMMON.IOUNITS'
7844 #ifdef MPI
7845       include "mpif.h"
7846 #endif
7847       include 'COMMON.FFIELD'
7848       include 'COMMON.DERIV'
7849       include 'COMMON.LOCAL'
7850       include 'COMMON.INTERACT'
7851       include 'COMMON.CONTACTS'
7852       include 'COMMON.CHAIN'
7853       include 'COMMON.CONTROL'
7854       include 'COMMON.SHIELD'
7855       double precision gx(3),gx1(3)
7856       integer num_cont_hb_old(maxres)
7857       logical lprn,ldone
7858       double precision eello4,eello5,eelo6,eello_turn6
7859       external eello4,eello5,eello6,eello_turn6
7860 C Set lprn=.true. for debugging
7861       lprn=.false.
7862       eturn6=0.0d0
7863       if (lprn) then
7864         write (iout,'(a)') 'Contact function values:'
7865         do i=nnt,nct-2
7866           write (iout,'(2i3,50(1x,i2,5f6.3))')
7867      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7868      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7869         enddo
7870       endif
7871       ecorr=0.0D0
7872       ecorr5=0.0d0
7873       ecorr6=0.0d0
7874 C Remove the loop below after debugging !!!
7875       do i=nnt,nct
7876         do j=1,3
7877           gradcorr(j,i)=0.0D0
7878           gradxorr(j,i)=0.0D0
7879         enddo
7880       enddo
7881 C Calculate the dipole-dipole interaction energies
7882       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7883       do i=iatel_s,iatel_e+1
7884         num_conti=num_cont_hb(i)
7885         do jj=1,num_conti
7886           j=jcont_hb(jj,i)
7887 #ifdef MOMENT
7888           call dipole(i,j,jj)
7889 #endif
7890         enddo
7891       enddo
7892       endif
7893 C Calculate the local-electrostatic correlation terms
7894 c                write (iout,*) "gradcorr5 in eello5 before loop"
7895 c                do iii=1,nres
7896 c                  write (iout,'(i5,3f10.5)')
7897 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7898 c                enddo
7899       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7900 c        write (iout,*) "corr loop i",i
7901         i1=i+1
7902         num_conti=num_cont_hb(i)
7903         num_conti1=num_cont_hb(i+1)
7904         do jj=1,num_conti
7905           j=jcont_hb(jj,i)
7906           jp=iabs(j)
7907           do kk=1,num_conti1
7908             j1=jcont_hb(kk,i1)
7909             jp1=iabs(j1)
7910 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7911 c     &         ' jj=',jj,' kk=',kk
7912 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7913             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7914      &          .or. j.lt.0 .and. j1.gt.0) .and.
7915      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7916 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7917 C The system gains extra energy.
7918               n_corr=n_corr+1
7919               sqd1=dsqrt(d_cont(jj,i))
7920               sqd2=dsqrt(d_cont(kk,i1))
7921               sred_geom = sqd1*sqd2
7922               IF (sred_geom.lt.cutoff_corr) THEN
7923                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7924      &            ekont,fprimcont)
7925 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7926 cd     &         ' jj=',jj,' kk=',kk
7927                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7928                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7929                 do l=1,3
7930                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7931                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7932                 enddo
7933                 n_corr1=n_corr1+1
7934 cd               write (iout,*) 'sred_geom=',sred_geom,
7935 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7936 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7937 cd               write (iout,*) "g_contij",g_contij
7938 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7939 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7940                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7941                 if (wcorr4.gt.0.0d0)
7942      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7943 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7944                   if (energy_dec.and.wcorr4.gt.0.0d0)
7945      1                 write (iout,'(a6,4i5,0pf7.3)')
7946      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7947 c                write (iout,*) "gradcorr5 before eello5"
7948 c                do iii=1,nres
7949 c                  write (iout,'(i5,3f10.5)')
7950 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7951 c                enddo
7952                 if (wcorr5.gt.0.0d0)
7953      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7954 c                write (iout,*) "gradcorr5 after eello5"
7955 c                do iii=1,nres
7956 c                  write (iout,'(i5,3f10.5)')
7957 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7958 c                enddo
7959                   if (energy_dec.and.wcorr5.gt.0.0d0)
7960      1                 write (iout,'(a6,4i5,0pf7.3)')
7961      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7962 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7963 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7964                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7965      &               .or. wturn6.eq.0.0d0))then
7966 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7967                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7968                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7969      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7970 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7971 cd     &            'ecorr6=',ecorr6
7972 cd                write (iout,'(4e15.5)') sred_geom,
7973 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7974 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7975 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7976                 else if (wturn6.gt.0.0d0
7977      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7978 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7979                   eturn6=eturn6+eello_turn6(i,jj,kk)
7980                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7981      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7982 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7983                 endif
7984               ENDIF
7985 1111          continue
7986             endif
7987           enddo ! kk
7988         enddo ! jj
7989       enddo ! i
7990       do i=1,nres
7991         num_cont_hb(i)=num_cont_hb_old(i)
7992       enddo
7993 c                write (iout,*) "gradcorr5 in eello5"
7994 c                do iii=1,nres
7995 c                  write (iout,'(i5,3f10.5)')
7996 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7997 c                enddo
7998       return
7999       end
8000 c------------------------------------------------------------------------------
8001       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8002       implicit real*8 (a-h,o-z)
8003       include 'DIMENSIONS'
8004       include 'DIMENSIONS.ZSCOPT'
8005       include 'COMMON.IOUNITS'
8006       include 'COMMON.DERIV'
8007       include 'COMMON.INTERACT'
8008       include 'COMMON.CONTACTS'
8009       include 'COMMON.SHIELD'
8010       include 'COMMON.CONTROL'
8011       double precision gx(3),gx1(3)
8012       logical lprn
8013       lprn=.false.
8014 C      print *,"wchodze",fac_shield(i),shield_mode
8015       eij=facont_hb(jj,i)
8016       ekl=facont_hb(kk,k)
8017       ees0pij=ees0p(jj,i)
8018       ees0pkl=ees0p(kk,k)
8019       ees0mij=ees0m(jj,i)
8020       ees0mkl=ees0m(kk,k)
8021       ekont=eij*ekl
8022       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8023 C*
8024 C     & fac_shield(i)**2*fac_shield(j)**2
8025 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8026 C Following 4 lines for diagnostics.
8027 cd    ees0pkl=0.0D0
8028 cd    ees0pij=1.0D0
8029 cd    ees0mkl=0.0D0
8030 cd    ees0mij=1.0D0
8031 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8032 c     & 'Contacts ',i,j,
8033 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8034 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8035 c     & 'gradcorr_long'
8036 C Calculate the multi-body contribution to energy.
8037 C      ecorr=ecorr+ekont*ees
8038 C Calculate multi-body contributions to the gradient.
8039       coeffpees0pij=coeffp*ees0pij
8040       coeffmees0mij=coeffm*ees0mij
8041       coeffpees0pkl=coeffp*ees0pkl
8042       coeffmees0mkl=coeffm*ees0mkl
8043       do ll=1,3
8044 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8045         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8046      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8047      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8048         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8049      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8050      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8051 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8052         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8053      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8054      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8055         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8056      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8057      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8058         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8059      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8060      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8061         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8062         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8063         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8064      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8065      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8066         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8067         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8068 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8069       enddo
8070 c      write (iout,*)
8071 cgrad      do m=i+1,j-1
8072 cgrad        do ll=1,3
8073 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8074 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8075 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8076 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8077 cgrad        enddo
8078 cgrad      enddo
8079 cgrad      do m=k+1,l-1
8080 cgrad        do ll=1,3
8081 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8082 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8083 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8084 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8085 cgrad        enddo
8086 cgrad      enddo
8087 c      write (iout,*) "ehbcorr",ekont*ees
8088 C      print *,ekont,ees,i,k
8089       ehbcorr=ekont*ees
8090 C now gradient over shielding
8091 C      return
8092       if (shield_mode.gt.0) then
8093        j=ees0plist(jj,i)
8094        l=ees0plist(kk,k)
8095 C        print *,i,j,fac_shield(i),fac_shield(j),
8096 C     &fac_shield(k),fac_shield(l)
8097         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8098      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8099           do ilist=1,ishield_list(i)
8100            iresshield=shield_list(ilist,i)
8101            do m=1,3
8102            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8103 C     &      *2.0
8104            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8105      &              rlocshield
8106      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8107             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8108      &+rlocshield
8109            enddo
8110           enddo
8111           do ilist=1,ishield_list(j)
8112            iresshield=shield_list(ilist,j)
8113            do m=1,3
8114            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8115 C     &     *2.0
8116            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8117      &              rlocshield
8118      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8119            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8120      &     +rlocshield
8121            enddo
8122           enddo
8123
8124           do ilist=1,ishield_list(k)
8125            iresshield=shield_list(ilist,k)
8126            do m=1,3
8127            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8128 C     &     *2.0
8129            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8130      &              rlocshield
8131      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8132            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8133      &     +rlocshield
8134            enddo
8135           enddo
8136           do ilist=1,ishield_list(l)
8137            iresshield=shield_list(ilist,l)
8138            do m=1,3
8139            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8140 C     &     *2.0
8141            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8142      &              rlocshield
8143      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8144            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8145      &     +rlocshield
8146            enddo
8147           enddo
8148 C          print *,gshieldx(m,iresshield)
8149           do m=1,3
8150             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8151      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8152             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8153      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8154             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8155      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8156             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8157      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8158
8159             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8160      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8161             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8162      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8163             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8164      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8165             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8166      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8167
8168            enddo
8169       endif
8170       endif
8171       return
8172       end
8173 #ifdef MOMENT
8174 C---------------------------------------------------------------------------
8175       subroutine dipole(i,j,jj)
8176       implicit real*8 (a-h,o-z)
8177       include 'DIMENSIONS'
8178       include 'DIMENSIONS.ZSCOPT'
8179       include 'COMMON.IOUNITS'
8180       include 'COMMON.CHAIN'
8181       include 'COMMON.FFIELD'
8182       include 'COMMON.DERIV'
8183       include 'COMMON.INTERACT'
8184       include 'COMMON.CONTACTS'
8185       include 'COMMON.TORSION'
8186       include 'COMMON.VAR'
8187       include 'COMMON.GEO'
8188       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8189      &  auxmat(2,2)
8190       iti1 = itortyp(itype(i+1))
8191       if (j.lt.nres-1) then
8192         itj1 = itype2loc(itype(j+1))
8193       else
8194         itj1=nloctyp
8195       endif
8196       do iii=1,2
8197         dipi(iii,1)=Ub2(iii,i)
8198         dipderi(iii)=Ub2der(iii,i)
8199         dipi(iii,2)=b1(iii,i+1)
8200         dipj(iii,1)=Ub2(iii,j)
8201         dipderj(iii)=Ub2der(iii,j)
8202         dipj(iii,2)=b1(iii,j+1)
8203       enddo
8204       kkk=0
8205       do iii=1,2
8206         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8207         do jjj=1,2
8208           kkk=kkk+1
8209           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8210         enddo
8211       enddo
8212       do kkk=1,5
8213         do lll=1,3
8214           mmm=0
8215           do iii=1,2
8216             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8217      &        auxvec(1))
8218             do jjj=1,2
8219               mmm=mmm+1
8220               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8221             enddo
8222           enddo
8223         enddo
8224       enddo
8225       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8226       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8227       do iii=1,2
8228         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8229       enddo
8230       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8231       do iii=1,2
8232         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8233       enddo
8234       return
8235       end
8236 #endif
8237 C---------------------------------------------------------------------------
8238       subroutine calc_eello(i,j,k,l,jj,kk)
8239 C
8240 C This subroutine computes matrices and vectors needed to calculate
8241 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8242 C
8243       implicit real*8 (a-h,o-z)
8244       include 'DIMENSIONS'
8245       include 'DIMENSIONS.ZSCOPT'
8246       include 'COMMON.IOUNITS'
8247       include 'COMMON.CHAIN'
8248       include 'COMMON.DERIV'
8249       include 'COMMON.INTERACT'
8250       include 'COMMON.CONTACTS'
8251       include 'COMMON.TORSION'
8252       include 'COMMON.VAR'
8253       include 'COMMON.GEO'
8254       include 'COMMON.FFIELD'
8255       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8256      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8257       logical lprn
8258       common /kutas/ lprn
8259 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8260 cd     & ' jj=',jj,' kk=',kk
8261 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8262 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8263 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8264       do iii=1,2
8265         do jjj=1,2
8266           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8267           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8268         enddo
8269       enddo
8270       call transpose2(aa1(1,1),aa1t(1,1))
8271       call transpose2(aa2(1,1),aa2t(1,1))
8272       do kkk=1,5
8273         do lll=1,3
8274           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8275      &      aa1tder(1,1,lll,kkk))
8276           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8277      &      aa2tder(1,1,lll,kkk))
8278         enddo
8279       enddo
8280       if (l.eq.j+1) then
8281 C parallel orientation of the two CA-CA-CA frames.
8282         if (i.gt.1) then
8283           iti=itype2loc(itype(i))
8284         else
8285           iti=nloctyp
8286         endif
8287         itk1=itype2loc(itype(k+1))
8288         itj=itype2loc(itype(j))
8289         if (l.lt.nres-1) then
8290           itl1=itype2loc(itype(l+1))
8291         else
8292           itl1=nloctyp
8293         endif
8294 C A1 kernel(j+1) A2T
8295 cd        do iii=1,2
8296 cd          write (iout,'(3f10.5,5x,3f10.5)')
8297 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8298 cd        enddo
8299         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8300      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8301      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8302 C Following matrices are needed only for 6-th order cumulants
8303         IF (wcorr6.gt.0.0d0) THEN
8304         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8305      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8306      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8307         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8308      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8309      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8310      &   ADtEAderx(1,1,1,1,1,1))
8311         lprn=.false.
8312         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8313      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8314      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8315      &   ADtEA1derx(1,1,1,1,1,1))
8316         ENDIF
8317 C End 6-th order cumulants
8318 cd        lprn=.false.
8319 cd        if (lprn) then
8320 cd        write (2,*) 'In calc_eello6'
8321 cd        do iii=1,2
8322 cd          write (2,*) 'iii=',iii
8323 cd          do kkk=1,5
8324 cd            write (2,*) 'kkk=',kkk
8325 cd            do jjj=1,2
8326 cd              write (2,'(3(2f10.5),5x)')
8327 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8328 cd            enddo
8329 cd          enddo
8330 cd        enddo
8331 cd        endif
8332         call transpose2(EUgder(1,1,k),auxmat(1,1))
8333         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8334         call transpose2(EUg(1,1,k),auxmat(1,1))
8335         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8336         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8337         do iii=1,2
8338           do kkk=1,5
8339             do lll=1,3
8340               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8341      &          EAEAderx(1,1,lll,kkk,iii,1))
8342             enddo
8343           enddo
8344         enddo
8345 C A1T kernel(i+1) A2
8346         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8347      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8348      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8349 C Following matrices are needed only for 6-th order cumulants
8350         IF (wcorr6.gt.0.0d0) THEN
8351         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8352      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8353      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8354         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8355      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8356      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8357      &   ADtEAderx(1,1,1,1,1,2))
8358         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8359      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8360      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8361      &   ADtEA1derx(1,1,1,1,1,2))
8362         ENDIF
8363 C End 6-th order cumulants
8364         call transpose2(EUgder(1,1,l),auxmat(1,1))
8365         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8366         call transpose2(EUg(1,1,l),auxmat(1,1))
8367         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8368         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8369         do iii=1,2
8370           do kkk=1,5
8371             do lll=1,3
8372               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8373      &          EAEAderx(1,1,lll,kkk,iii,2))
8374             enddo
8375           enddo
8376         enddo
8377 C AEAb1 and AEAb2
8378 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8379 C They are needed only when the fifth- or the sixth-order cumulants are
8380 C indluded.
8381         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8382         call transpose2(AEA(1,1,1),auxmat(1,1))
8383         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8384         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8385         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8386         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8387         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8388         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8389         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8390         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8391         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8392         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8393         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8394         call transpose2(AEA(1,1,2),auxmat(1,1))
8395         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8396         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8397         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8398         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8399         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8400         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8401         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8402         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8403         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8404         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8405         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8406 C Calculate the Cartesian derivatives of the vectors.
8407         do iii=1,2
8408           do kkk=1,5
8409             do lll=1,3
8410               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8411               call matvec2(auxmat(1,1),b1(1,i),
8412      &          AEAb1derx(1,lll,kkk,iii,1,1))
8413               call matvec2(auxmat(1,1),Ub2(1,i),
8414      &          AEAb2derx(1,lll,kkk,iii,1,1))
8415               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8416      &          AEAb1derx(1,lll,kkk,iii,2,1))
8417               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8418      &          AEAb2derx(1,lll,kkk,iii,2,1))
8419               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8420               call matvec2(auxmat(1,1),b1(1,j),
8421      &          AEAb1derx(1,lll,kkk,iii,1,2))
8422               call matvec2(auxmat(1,1),Ub2(1,j),
8423      &          AEAb2derx(1,lll,kkk,iii,1,2))
8424               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8425      &          AEAb1derx(1,lll,kkk,iii,2,2))
8426               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8427      &          AEAb2derx(1,lll,kkk,iii,2,2))
8428             enddo
8429           enddo
8430         enddo
8431         ENDIF
8432 C End vectors
8433       else
8434 C Antiparallel orientation of the two CA-CA-CA frames.
8435         if (i.gt.1) then
8436           iti=itype2loc(itype(i))
8437         else
8438           iti=nloctyp
8439         endif
8440         itk1=itype2loc(itype(k+1))
8441         itl=itype2loc(itype(l))
8442         itj=itype2loc(itype(j))
8443         if (j.lt.nres-1) then
8444           itj1=itype2loc(itype(j+1))
8445         else
8446           itj1=nloctyp
8447         endif
8448 C A2 kernel(j-1)T A1T
8449         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8450      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8451      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8452 C Following matrices are needed only for 6-th order cumulants
8453         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8454      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8455         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8456      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8457      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8458         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8459      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8460      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8461      &   ADtEAderx(1,1,1,1,1,1))
8462         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8463      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8464      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8465      &   ADtEA1derx(1,1,1,1,1,1))
8466         ENDIF
8467 C End 6-th order cumulants
8468         call transpose2(EUgder(1,1,k),auxmat(1,1))
8469         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8470         call transpose2(EUg(1,1,k),auxmat(1,1))
8471         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8472         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8473         do iii=1,2
8474           do kkk=1,5
8475             do lll=1,3
8476               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8477      &          EAEAderx(1,1,lll,kkk,iii,1))
8478             enddo
8479           enddo
8480         enddo
8481 C A2T kernel(i+1)T A1
8482         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8483      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8484      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8485 C Following matrices are needed only for 6-th order cumulants
8486         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8487      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8488         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8489      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8490      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8491         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8492      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8493      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8494      &   ADtEAderx(1,1,1,1,1,2))
8495         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8496      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8497      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8498      &   ADtEA1derx(1,1,1,1,1,2))
8499         ENDIF
8500 C End 6-th order cumulants
8501         call transpose2(EUgder(1,1,j),auxmat(1,1))
8502         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8503         call transpose2(EUg(1,1,j),auxmat(1,1))
8504         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8505         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8506         do iii=1,2
8507           do kkk=1,5
8508             do lll=1,3
8509               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8510      &          EAEAderx(1,1,lll,kkk,iii,2))
8511             enddo
8512           enddo
8513         enddo
8514 C AEAb1 and AEAb2
8515 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8516 C They are needed only when the fifth- or the sixth-order cumulants are
8517 C indluded.
8518         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8519      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8520         call transpose2(AEA(1,1,1),auxmat(1,1))
8521         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8522         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8523         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8524         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8525         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8526         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8527         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8528         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8529         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8530         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8531         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8532         call transpose2(AEA(1,1,2),auxmat(1,1))
8533         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8534         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8535         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8536         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8537         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8538         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8539         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8540         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8541         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8542         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8543         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8544 C Calculate the Cartesian derivatives of the vectors.
8545         do iii=1,2
8546           do kkk=1,5
8547             do lll=1,3
8548               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8549               call matvec2(auxmat(1,1),b1(1,i),
8550      &          AEAb1derx(1,lll,kkk,iii,1,1))
8551               call matvec2(auxmat(1,1),Ub2(1,i),
8552      &          AEAb2derx(1,lll,kkk,iii,1,1))
8553               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8554      &          AEAb1derx(1,lll,kkk,iii,2,1))
8555               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8556      &          AEAb2derx(1,lll,kkk,iii,2,1))
8557               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8558               call matvec2(auxmat(1,1),b1(1,l),
8559      &          AEAb1derx(1,lll,kkk,iii,1,2))
8560               call matvec2(auxmat(1,1),Ub2(1,l),
8561      &          AEAb2derx(1,lll,kkk,iii,1,2))
8562               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8563      &          AEAb1derx(1,lll,kkk,iii,2,2))
8564               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8565      &          AEAb2derx(1,lll,kkk,iii,2,2))
8566             enddo
8567           enddo
8568         enddo
8569         ENDIF
8570 C End vectors
8571       endif
8572       return
8573       end
8574 C---------------------------------------------------------------------------
8575       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8576      &  KK,KKderg,AKA,AKAderg,AKAderx)
8577       implicit none
8578       integer nderg
8579       logical transp
8580       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8581      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8582      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8583       integer iii,kkk,lll
8584       integer jjj,mmm
8585       logical lprn
8586       common /kutas/ lprn
8587       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8588       do iii=1,nderg
8589         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8590      &    AKAderg(1,1,iii))
8591       enddo
8592 cd      if (lprn) write (2,*) 'In kernel'
8593       do kkk=1,5
8594 cd        if (lprn) write (2,*) 'kkk=',kkk
8595         do lll=1,3
8596           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8597      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8598 cd          if (lprn) then
8599 cd            write (2,*) 'lll=',lll
8600 cd            write (2,*) 'iii=1'
8601 cd            do jjj=1,2
8602 cd              write (2,'(3(2f10.5),5x)')
8603 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8604 cd            enddo
8605 cd          endif
8606           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8607      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8608 cd          if (lprn) then
8609 cd            write (2,*) 'lll=',lll
8610 cd            write (2,*) 'iii=2'
8611 cd            do jjj=1,2
8612 cd              write (2,'(3(2f10.5),5x)')
8613 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8614 cd            enddo
8615 cd          endif
8616         enddo
8617       enddo
8618       return
8619       end
8620 C---------------------------------------------------------------------------
8621       double precision function eello4(i,j,k,l,jj,kk)
8622       implicit real*8 (a-h,o-z)
8623       include 'DIMENSIONS'
8624       include 'DIMENSIONS.ZSCOPT'
8625       include 'COMMON.IOUNITS'
8626       include 'COMMON.CHAIN'
8627       include 'COMMON.DERIV'
8628       include 'COMMON.INTERACT'
8629       include 'COMMON.CONTACTS'
8630       include 'COMMON.TORSION'
8631       include 'COMMON.VAR'
8632       include 'COMMON.GEO'
8633       double precision pizda(2,2),ggg1(3),ggg2(3)
8634 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8635 cd        eello4=0.0d0
8636 cd        return
8637 cd      endif
8638 cd      print *,'eello4:',i,j,k,l,jj,kk
8639 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8640 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8641 cold      eij=facont_hb(jj,i)
8642 cold      ekl=facont_hb(kk,k)
8643 cold      ekont=eij*ekl
8644       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8645       if (calc_grad) then
8646 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8647       gcorr_loc(k-1)=gcorr_loc(k-1)
8648      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8649       if (l.eq.j+1) then
8650         gcorr_loc(l-1)=gcorr_loc(l-1)
8651      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8652       else
8653         gcorr_loc(j-1)=gcorr_loc(j-1)
8654      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8655       endif
8656       do iii=1,2
8657         do kkk=1,5
8658           do lll=1,3
8659             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8660      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8661 cd            derx(lll,kkk,iii)=0.0d0
8662           enddo
8663         enddo
8664       enddo
8665 cd      gcorr_loc(l-1)=0.0d0
8666 cd      gcorr_loc(j-1)=0.0d0
8667 cd      gcorr_loc(k-1)=0.0d0
8668 cd      eel4=1.0d0
8669 cd      write (iout,*)'Contacts have occurred for peptide groups',
8670 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8671 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8672       if (j.lt.nres-1) then
8673         j1=j+1
8674         j2=j-1
8675       else
8676         j1=j-1
8677         j2=j-2
8678       endif
8679       if (l.lt.nres-1) then
8680         l1=l+1
8681         l2=l-1
8682       else
8683         l1=l-1
8684         l2=l-2
8685       endif
8686       do ll=1,3
8687 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8688 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8689         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8690         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8691 cgrad        ghalf=0.5d0*ggg1(ll)
8692         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8693         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8694         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8695         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8696         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8697         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8698 cgrad        ghalf=0.5d0*ggg2(ll)
8699         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8700         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8701         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8702         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8703         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8704         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8705       enddo
8706 cgrad      do m=i+1,j-1
8707 cgrad        do ll=1,3
8708 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8709 cgrad        enddo
8710 cgrad      enddo
8711 cgrad      do m=k+1,l-1
8712 cgrad        do ll=1,3
8713 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8714 cgrad        enddo
8715 cgrad      enddo
8716 cgrad      do m=i+2,j2
8717 cgrad        do ll=1,3
8718 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8719 cgrad        enddo
8720 cgrad      enddo
8721 cgrad      do m=k+2,l2
8722 cgrad        do ll=1,3
8723 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8724 cgrad        enddo
8725 cgrad      enddo
8726 cd      do iii=1,nres-3
8727 cd        write (2,*) iii,gcorr_loc(iii)
8728 cd      enddo
8729       endif ! calc_grad
8730       eello4=ekont*eel4
8731 cd      write (2,*) 'ekont',ekont
8732 cd      write (iout,*) 'eello4',ekont*eel4
8733       return
8734       end
8735 C---------------------------------------------------------------------------
8736       double precision function eello5(i,j,k,l,jj,kk)
8737       implicit real*8 (a-h,o-z)
8738       include 'DIMENSIONS'
8739       include 'DIMENSIONS.ZSCOPT'
8740       include 'COMMON.IOUNITS'
8741       include 'COMMON.CHAIN'
8742       include 'COMMON.DERIV'
8743       include 'COMMON.INTERACT'
8744       include 'COMMON.CONTACTS'
8745       include 'COMMON.TORSION'
8746       include 'COMMON.VAR'
8747       include 'COMMON.GEO'
8748       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8749       double precision ggg1(3),ggg2(3)
8750 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8751 C                                                                              C
8752 C                            Parallel chains                                   C
8753 C                                                                              C
8754 C          o             o                   o             o                   C
8755 C         /l\           / \             \   / \           / \   /              C
8756 C        /   \         /   \             \ /   \         /   \ /               C
8757 C       j| o |l1       | o |              o| o |         | o |o                C
8758 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8759 C      \i/   \         /   \ /             /   \         /   \                 C
8760 C       o    k1             o                                                  C
8761 C         (I)          (II)                (III)          (IV)                 C
8762 C                                                                              C
8763 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8764 C                                                                              C
8765 C                            Antiparallel chains                               C
8766 C                                                                              C
8767 C          o             o                   o             o                   C
8768 C         /j\           / \             \   / \           / \   /              C
8769 C        /   \         /   \             \ /   \         /   \ /               C
8770 C      j1| o |l        | o |              o| o |         | o |o                C
8771 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8772 C      \i/   \         /   \ /             /   \         /   \                 C
8773 C       o     k1            o                                                  C
8774 C         (I)          (II)                (III)          (IV)                 C
8775 C                                                                              C
8776 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8777 C                                                                              C
8778 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8779 C                                                                              C
8780 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8781 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8782 cd        eello5=0.0d0
8783 cd        return
8784 cd      endif
8785 cd      write (iout,*)
8786 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8787 cd     &   ' and',k,l
8788       itk=itype2loc(itype(k))
8789       itl=itype2loc(itype(l))
8790       itj=itype2loc(itype(j))
8791       eello5_1=0.0d0
8792       eello5_2=0.0d0
8793       eello5_3=0.0d0
8794       eello5_4=0.0d0
8795 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8796 cd     &   eel5_3_num,eel5_4_num)
8797       do iii=1,2
8798         do kkk=1,5
8799           do lll=1,3
8800             derx(lll,kkk,iii)=0.0d0
8801           enddo
8802         enddo
8803       enddo
8804 cd      eij=facont_hb(jj,i)
8805 cd      ekl=facont_hb(kk,k)
8806 cd      ekont=eij*ekl
8807 cd      write (iout,*)'Contacts have occurred for peptide groups',
8808 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8809 cd      goto 1111
8810 C Contribution from the graph I.
8811 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8812 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8813       call transpose2(EUg(1,1,k),auxmat(1,1))
8814       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8815       vv(1)=pizda(1,1)-pizda(2,2)
8816       vv(2)=pizda(1,2)+pizda(2,1)
8817       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8818      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8819       if (calc_grad) then
8820 C Explicit gradient in virtual-dihedral angles.
8821       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8822      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8823      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8824       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8825       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8826       vv(1)=pizda(1,1)-pizda(2,2)
8827       vv(2)=pizda(1,2)+pizda(2,1)
8828       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8829      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8830      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8831       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8832       vv(1)=pizda(1,1)-pizda(2,2)
8833       vv(2)=pizda(1,2)+pizda(2,1)
8834       if (l.eq.j+1) then
8835         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8836      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8837      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8838       else
8839         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8840      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8841      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8842       endif
8843 C Cartesian gradient
8844       do iii=1,2
8845         do kkk=1,5
8846           do lll=1,3
8847             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8848      &        pizda(1,1))
8849             vv(1)=pizda(1,1)-pizda(2,2)
8850             vv(2)=pizda(1,2)+pizda(2,1)
8851             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8852      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8853      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8854           enddo
8855         enddo
8856       enddo
8857       endif ! calc_grad
8858 c      goto 1112
8859 c1111  continue
8860 C Contribution from graph II
8861       call transpose2(EE(1,1,k),auxmat(1,1))
8862       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8863       vv(1)=pizda(1,1)+pizda(2,2)
8864       vv(2)=pizda(2,1)-pizda(1,2)
8865       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8866      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8867       if (calc_grad) then
8868 C Explicit gradient in virtual-dihedral angles.
8869       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8870      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8871       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8872       vv(1)=pizda(1,1)+pizda(2,2)
8873       vv(2)=pizda(2,1)-pizda(1,2)
8874       if (l.eq.j+1) then
8875         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8876      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8877      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8878       else
8879         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8880      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8881      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8882       endif
8883 C Cartesian gradient
8884       do iii=1,2
8885         do kkk=1,5
8886           do lll=1,3
8887             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8888      &        pizda(1,1))
8889             vv(1)=pizda(1,1)+pizda(2,2)
8890             vv(2)=pizda(2,1)-pizda(1,2)
8891             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8892      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8893      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8894           enddo
8895         enddo
8896       enddo
8897       endif ! calc_grad
8898 cd      goto 1112
8899 cd1111  continue
8900       if (l.eq.j+1) then
8901 cd        goto 1110
8902 C Parallel orientation
8903 C Contribution from graph III
8904         call transpose2(EUg(1,1,l),auxmat(1,1))
8905         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8906         vv(1)=pizda(1,1)-pizda(2,2)
8907         vv(2)=pizda(1,2)+pizda(2,1)
8908         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8909      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8910         if (calc_grad) then
8911 C Explicit gradient in virtual-dihedral angles.
8912         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8913      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8914      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8915         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8916         vv(1)=pizda(1,1)-pizda(2,2)
8917         vv(2)=pizda(1,2)+pizda(2,1)
8918         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8919      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8920      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8921         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8922         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8923         vv(1)=pizda(1,1)-pizda(2,2)
8924         vv(2)=pizda(1,2)+pizda(2,1)
8925         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8926      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8927      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8928 C Cartesian gradient
8929         do iii=1,2
8930           do kkk=1,5
8931             do lll=1,3
8932               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8933      &          pizda(1,1))
8934               vv(1)=pizda(1,1)-pizda(2,2)
8935               vv(2)=pizda(1,2)+pizda(2,1)
8936               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8937      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8938      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8939             enddo
8940           enddo
8941         enddo
8942 cd        goto 1112
8943 C Contribution from graph IV
8944 cd1110    continue
8945         call transpose2(EE(1,1,l),auxmat(1,1))
8946         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8947         vv(1)=pizda(1,1)+pizda(2,2)
8948         vv(2)=pizda(2,1)-pizda(1,2)
8949         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8950      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8951 C Explicit gradient in virtual-dihedral angles.
8952         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8953      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8954         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8955         vv(1)=pizda(1,1)+pizda(2,2)
8956         vv(2)=pizda(2,1)-pizda(1,2)
8957         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8958      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8959      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8960 C Cartesian gradient
8961         do iii=1,2
8962           do kkk=1,5
8963             do lll=1,3
8964               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8965      &          pizda(1,1))
8966               vv(1)=pizda(1,1)+pizda(2,2)
8967               vv(2)=pizda(2,1)-pizda(1,2)
8968               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8969      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8970      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8971             enddo
8972           enddo
8973         enddo
8974         endif ! calc_grad
8975       else
8976 C Antiparallel orientation
8977 C Contribution from graph III
8978 c        goto 1110
8979         call transpose2(EUg(1,1,j),auxmat(1,1))
8980         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8981         vv(1)=pizda(1,1)-pizda(2,2)
8982         vv(2)=pizda(1,2)+pizda(2,1)
8983         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8984      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8985         if (calc_grad) then
8986 C Explicit gradient in virtual-dihedral angles.
8987         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8988      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8989      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8990         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8991         vv(1)=pizda(1,1)-pizda(2,2)
8992         vv(2)=pizda(1,2)+pizda(2,1)
8993         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8994      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8995      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8996         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8997         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8998         vv(1)=pizda(1,1)-pizda(2,2)
8999         vv(2)=pizda(1,2)+pizda(2,1)
9000         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9001      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9002      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9003 C Cartesian gradient
9004         do iii=1,2
9005           do kkk=1,5
9006             do lll=1,3
9007               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9008      &          pizda(1,1))
9009               vv(1)=pizda(1,1)-pizda(2,2)
9010               vv(2)=pizda(1,2)+pizda(2,1)
9011               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9012      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9013      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9014             enddo
9015           enddo
9016         enddo
9017         endif ! calc_grad
9018 cd        goto 1112
9019 C Contribution from graph IV
9020 1110    continue
9021         call transpose2(EE(1,1,j),auxmat(1,1))
9022         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9023         vv(1)=pizda(1,1)+pizda(2,2)
9024         vv(2)=pizda(2,1)-pizda(1,2)
9025         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9026      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9027         if (calc_grad) then
9028 C Explicit gradient in virtual-dihedral angles.
9029         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9030      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9031         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9032         vv(1)=pizda(1,1)+pizda(2,2)
9033         vv(2)=pizda(2,1)-pizda(1,2)
9034         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9035      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9036      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9037 C Cartesian gradient
9038         do iii=1,2
9039           do kkk=1,5
9040             do lll=1,3
9041               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9042      &          pizda(1,1))
9043               vv(1)=pizda(1,1)+pizda(2,2)
9044               vv(2)=pizda(2,1)-pizda(1,2)
9045               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9046      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9047      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9048             enddo
9049           enddo
9050         enddo
9051         endif ! calc_grad
9052       endif
9053 1112  continue
9054       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9055 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9056 cd        write (2,*) 'ijkl',i,j,k,l
9057 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9058 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9059 cd      endif
9060 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9061 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9062 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9063 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9064       if (calc_grad) then
9065       if (j.lt.nres-1) then
9066         j1=j+1
9067         j2=j-1
9068       else
9069         j1=j-1
9070         j2=j-2
9071       endif
9072       if (l.lt.nres-1) then
9073         l1=l+1
9074         l2=l-1
9075       else
9076         l1=l-1
9077         l2=l-2
9078       endif
9079 cd      eij=1.0d0
9080 cd      ekl=1.0d0
9081 cd      ekont=1.0d0
9082 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9083 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9084 C        summed up outside the subrouine as for the other subroutines
9085 C        handling long-range interactions. The old code is commented out
9086 C        with "cgrad" to keep track of changes.
9087       do ll=1,3
9088 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9089 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9090         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9091         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9092 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9093 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9094 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9095 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9096 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9097 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9098 c     &   gradcorr5ij,
9099 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9100 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9101 cgrad        ghalf=0.5d0*ggg1(ll)
9102 cd        ghalf=0.0d0
9103         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9104         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9105         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9106         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9107         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9108         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9109 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9110 cgrad        ghalf=0.5d0*ggg2(ll)
9111 cd        ghalf=0.0d0
9112         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9113         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9114         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9115         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9116         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9117         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9118       enddo
9119       endif ! calc_grad
9120 cd      goto 1112
9121 cgrad      do m=i+1,j-1
9122 cgrad        do ll=1,3
9123 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9124 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9125 cgrad        enddo
9126 cgrad      enddo
9127 cgrad      do m=k+1,l-1
9128 cgrad        do ll=1,3
9129 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9130 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9131 cgrad        enddo
9132 cgrad      enddo
9133 c1112  continue
9134 cgrad      do m=i+2,j2
9135 cgrad        do ll=1,3
9136 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9137 cgrad        enddo
9138 cgrad      enddo
9139 cgrad      do m=k+2,l2
9140 cgrad        do ll=1,3
9141 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9142 cgrad        enddo
9143 cgrad      enddo
9144 cd      do iii=1,nres-3
9145 cd        write (2,*) iii,g_corr5_loc(iii)
9146 cd      enddo
9147       eello5=ekont*eel5
9148 cd      write (2,*) 'ekont',ekont
9149 cd      write (iout,*) 'eello5',ekont*eel5
9150       return
9151       end
9152 c--------------------------------------------------------------------------
9153       double precision function eello6(i,j,k,l,jj,kk)
9154       implicit real*8 (a-h,o-z)
9155       include 'DIMENSIONS'
9156       include 'DIMENSIONS.ZSCOPT'
9157       include 'COMMON.IOUNITS'
9158       include 'COMMON.CHAIN'
9159       include 'COMMON.DERIV'
9160       include 'COMMON.INTERACT'
9161       include 'COMMON.CONTACTS'
9162       include 'COMMON.TORSION'
9163       include 'COMMON.VAR'
9164       include 'COMMON.GEO'
9165       include 'COMMON.FFIELD'
9166       double precision ggg1(3),ggg2(3)
9167 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9168 cd        eello6=0.0d0
9169 cd        return
9170 cd      endif
9171 cd      write (iout,*)
9172 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9173 cd     &   ' and',k,l
9174       eello6_1=0.0d0
9175       eello6_2=0.0d0
9176       eello6_3=0.0d0
9177       eello6_4=0.0d0
9178       eello6_5=0.0d0
9179       eello6_6=0.0d0
9180 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9181 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9182       do iii=1,2
9183         do kkk=1,5
9184           do lll=1,3
9185             derx(lll,kkk,iii)=0.0d0
9186           enddo
9187         enddo
9188       enddo
9189 cd      eij=facont_hb(jj,i)
9190 cd      ekl=facont_hb(kk,k)
9191 cd      ekont=eij*ekl
9192 cd      eij=1.0d0
9193 cd      ekl=1.0d0
9194 cd      ekont=1.0d0
9195       if (l.eq.j+1) then
9196         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9197         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9198         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9199         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9200         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9201         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9202       else
9203         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9204         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9205         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9206         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9207         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9208           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9209         else
9210           eello6_5=0.0d0
9211         endif
9212         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9213       endif
9214 C If turn contributions are considered, they will be handled separately.
9215       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9216 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9217 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9218 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9219 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9220 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9221 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9222 cd      goto 1112
9223       if (calc_grad) then
9224       if (j.lt.nres-1) then
9225         j1=j+1
9226         j2=j-1
9227       else
9228         j1=j-1
9229         j2=j-2
9230       endif
9231       if (l.lt.nres-1) then
9232         l1=l+1
9233         l2=l-1
9234       else
9235         l1=l-1
9236         l2=l-2
9237       endif
9238       do ll=1,3
9239 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9240 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9241 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9242 cgrad        ghalf=0.5d0*ggg1(ll)
9243 cd        ghalf=0.0d0
9244         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9245         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9246         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9247         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9248         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9249         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9250         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9251         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9252 cgrad        ghalf=0.5d0*ggg2(ll)
9253 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9254 cd        ghalf=0.0d0
9255         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9256         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9257         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9258         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9259         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9260         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9261       enddo
9262       endif ! calc_grad
9263 cd      goto 1112
9264 cgrad      do m=i+1,j-1
9265 cgrad        do ll=1,3
9266 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9267 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9268 cgrad        enddo
9269 cgrad      enddo
9270 cgrad      do m=k+1,l-1
9271 cgrad        do ll=1,3
9272 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9273 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9274 cgrad        enddo
9275 cgrad      enddo
9276 cgrad1112  continue
9277 cgrad      do m=i+2,j2
9278 cgrad        do ll=1,3
9279 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9280 cgrad        enddo
9281 cgrad      enddo
9282 cgrad      do m=k+2,l2
9283 cgrad        do ll=1,3
9284 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9285 cgrad        enddo
9286 cgrad      enddo
9287 cd      do iii=1,nres-3
9288 cd        write (2,*) iii,g_corr6_loc(iii)
9289 cd      enddo
9290       eello6=ekont*eel6
9291 cd      write (2,*) 'ekont',ekont
9292 cd      write (iout,*) 'eello6',ekont*eel6
9293       return
9294       end
9295 c--------------------------------------------------------------------------
9296       double precision function eello6_graph1(i,j,k,l,imat,swap)
9297       implicit real*8 (a-h,o-z)
9298       include 'DIMENSIONS'
9299       include 'DIMENSIONS.ZSCOPT'
9300       include 'COMMON.IOUNITS'
9301       include 'COMMON.CHAIN'
9302       include 'COMMON.DERIV'
9303       include 'COMMON.INTERACT'
9304       include 'COMMON.CONTACTS'
9305       include 'COMMON.TORSION'
9306       include 'COMMON.VAR'
9307       include 'COMMON.GEO'
9308       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9309       logical swap
9310       logical lprn
9311       common /kutas/ lprn
9312 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9313 C                                                                              C
9314 C      Parallel       Antiparallel                                             C
9315 C                                                                              C
9316 C          o             o                                                     C
9317 C         /l\           /j\                                                    C
9318 C        /   \         /   \                                                   C
9319 C       /| o |         | o |\                                                  C
9320 C     \ j|/k\|  /   \  |/k\|l /                                                C
9321 C      \ /   \ /     \ /   \ /                                                 C
9322 C       o     o       o     o                                                  C
9323 C       i             i                                                        C
9324 C                                                                              C
9325 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9326       itk=itype2loc(itype(k))
9327       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9328       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9329       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9330       call transpose2(EUgC(1,1,k),auxmat(1,1))
9331       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9332       vv1(1)=pizda1(1,1)-pizda1(2,2)
9333       vv1(2)=pizda1(1,2)+pizda1(2,1)
9334       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9335       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9336       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9337       s5=scalar2(vv(1),Dtobr2(1,i))
9338 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9339       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9340       if (calc_grad) then
9341       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9342      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9343      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9344      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9345      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9346      & +scalar2(vv(1),Dtobr2der(1,i)))
9347       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9348       vv1(1)=pizda1(1,1)-pizda1(2,2)
9349       vv1(2)=pizda1(1,2)+pizda1(2,1)
9350       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9351       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9352       if (l.eq.j+1) then
9353         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9354      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9355      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9356      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9357      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9358       else
9359         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9360      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9361      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9362      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9363      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9364       endif
9365       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9366       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9367       vv1(1)=pizda1(1,1)-pizda1(2,2)
9368       vv1(2)=pizda1(1,2)+pizda1(2,1)
9369       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9370      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9371      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9372      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9373       do iii=1,2
9374         if (swap) then
9375           ind=3-iii
9376         else
9377           ind=iii
9378         endif
9379         do kkk=1,5
9380           do lll=1,3
9381             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9382             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9383             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9384             call transpose2(EUgC(1,1,k),auxmat(1,1))
9385             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9386      &        pizda1(1,1))
9387             vv1(1)=pizda1(1,1)-pizda1(2,2)
9388             vv1(2)=pizda1(1,2)+pizda1(2,1)
9389             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9390             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9391      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9392             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9393      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9394             s5=scalar2(vv(1),Dtobr2(1,i))
9395             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9396           enddo
9397         enddo
9398       enddo
9399       endif ! calc_grad
9400       return
9401       end
9402 c----------------------------------------------------------------------------
9403       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9404       implicit real*8 (a-h,o-z)
9405       include 'DIMENSIONS'
9406       include 'DIMENSIONS.ZSCOPT'
9407       include 'COMMON.IOUNITS'
9408       include 'COMMON.CHAIN'
9409       include 'COMMON.DERIV'
9410       include 'COMMON.INTERACT'
9411       include 'COMMON.CONTACTS'
9412       include 'COMMON.TORSION'
9413       include 'COMMON.VAR'
9414       include 'COMMON.GEO'
9415       logical swap
9416       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9417      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9418       logical lprn
9419       common /kutas/ lprn
9420 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9421 C                                                                              C
9422 C      Parallel       Antiparallel                                             C
9423 C                                                                              C
9424 C          o             o                                                     C
9425 C     \   /l\           /j\   /                                                C
9426 C      \ /   \         /   \ /                                                 C
9427 C       o| o |         | o |o                                                  C
9428 C     \ j|/k\|      \  |/k\|l                                                  C
9429 C      \ /   \       \ /   \                                                   C
9430 C       o             o                                                        C
9431 C       i             i                                                        C
9432 C                                                                              C
9433 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9434 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9435 C AL 7/4/01 s1 would occur in the sixth-order moment,
9436 C           but not in a cluster cumulant
9437 #ifdef MOMENT
9438       s1=dip(1,jj,i)*dip(1,kk,k)
9439 #endif
9440       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9441       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9442       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9443       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9444       call transpose2(EUg(1,1,k),auxmat(1,1))
9445       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9446       vv(1)=pizda(1,1)-pizda(2,2)
9447       vv(2)=pizda(1,2)+pizda(2,1)
9448       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9449 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9450 #ifdef MOMENT
9451       eello6_graph2=-(s1+s2+s3+s4)
9452 #else
9453       eello6_graph2=-(s2+s3+s4)
9454 #endif
9455 c      eello6_graph2=-s3
9456 C Derivatives in gamma(i-1)
9457       if (calc_grad) then
9458       if (i.gt.1) then
9459 #ifdef MOMENT
9460         s1=dipderg(1,jj,i)*dip(1,kk,k)
9461 #endif
9462         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9463         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9464         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9465         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9466 #ifdef MOMENT
9467         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9468 #else
9469         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9470 #endif
9471 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9472       endif
9473 C Derivatives in gamma(k-1)
9474 #ifdef MOMENT
9475       s1=dip(1,jj,i)*dipderg(1,kk,k)
9476 #endif
9477       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9478       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9479       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9480       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9481       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9482       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9483       vv(1)=pizda(1,1)-pizda(2,2)
9484       vv(2)=pizda(1,2)+pizda(2,1)
9485       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9486 #ifdef MOMENT
9487       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9488 #else
9489       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9490 #endif
9491 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9492 C Derivatives in gamma(j-1) or gamma(l-1)
9493       if (j.gt.1) then
9494 #ifdef MOMENT
9495         s1=dipderg(3,jj,i)*dip(1,kk,k)
9496 #endif
9497         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9498         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9499         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9500         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9501         vv(1)=pizda(1,1)-pizda(2,2)
9502         vv(2)=pizda(1,2)+pizda(2,1)
9503         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9504 #ifdef MOMENT
9505         if (swap) then
9506           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9507         else
9508           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9509         endif
9510 #endif
9511         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9512 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9513       endif
9514 C Derivatives in gamma(l-1) or gamma(j-1)
9515       if (l.gt.1) then
9516 #ifdef MOMENT
9517         s1=dip(1,jj,i)*dipderg(3,kk,k)
9518 #endif
9519         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9520         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9521         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9522         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9523         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9524         vv(1)=pizda(1,1)-pizda(2,2)
9525         vv(2)=pizda(1,2)+pizda(2,1)
9526         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9527 #ifdef MOMENT
9528         if (swap) then
9529           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9530         else
9531           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9532         endif
9533 #endif
9534         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9535 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9536       endif
9537 C Cartesian derivatives.
9538       if (lprn) then
9539         write (2,*) 'In eello6_graph2'
9540         do iii=1,2
9541           write (2,*) 'iii=',iii
9542           do kkk=1,5
9543             write (2,*) 'kkk=',kkk
9544             do jjj=1,2
9545               write (2,'(3(2f10.5),5x)')
9546      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9547             enddo
9548           enddo
9549         enddo
9550       endif
9551       do iii=1,2
9552         do kkk=1,5
9553           do lll=1,3
9554 #ifdef MOMENT
9555             if (iii.eq.1) then
9556               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9557             else
9558               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9559             endif
9560 #endif
9561             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9562      &        auxvec(1))
9563             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9564             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9565      &        auxvec(1))
9566             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9567             call transpose2(EUg(1,1,k),auxmat(1,1))
9568             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9569      &        pizda(1,1))
9570             vv(1)=pizda(1,1)-pizda(2,2)
9571             vv(2)=pizda(1,2)+pizda(2,1)
9572             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9573 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9574 #ifdef MOMENT
9575             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9576 #else
9577             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9578 #endif
9579             if (swap) then
9580               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9581             else
9582               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9583             endif
9584           enddo
9585         enddo
9586       enddo
9587       endif ! calc_grad
9588       return
9589       end
9590 c----------------------------------------------------------------------------
9591       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9592       implicit real*8 (a-h,o-z)
9593       include 'DIMENSIONS'
9594       include 'DIMENSIONS.ZSCOPT'
9595       include 'COMMON.IOUNITS'
9596       include 'COMMON.CHAIN'
9597       include 'COMMON.DERIV'
9598       include 'COMMON.INTERACT'
9599       include 'COMMON.CONTACTS'
9600       include 'COMMON.TORSION'
9601       include 'COMMON.VAR'
9602       include 'COMMON.GEO'
9603       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9604       logical swap
9605 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9606 C                                                                              C
9607 C      Parallel       Antiparallel                                             C
9608 C                                                                              C
9609 C          o             o                                                     C
9610 C         /l\   /   \   /j\                                                    C
9611 C        /   \ /     \ /   \                                                   C
9612 C       /| o |o       o| o |\                                                  C
9613 C       j|/k\|  /      |/k\|l /                                                C
9614 C        /   \ /       /   \ /                                                 C
9615 C       /     o       /     o                                                  C
9616 C       i             i                                                        C
9617 C                                                                              C
9618 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9619 C
9620 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9621 C           energy moment and not to the cluster cumulant.
9622       iti=itortyp(itype(i))
9623       if (j.lt.nres-1) then
9624         itj1=itype2loc(itype(j+1))
9625       else
9626         itj1=nloctyp
9627       endif
9628       itk=itype2loc(itype(k))
9629       itk1=itype2loc(itype(k+1))
9630       if (l.lt.nres-1) then
9631         itl1=itype2loc(itype(l+1))
9632       else
9633         itl1=nloctyp
9634       endif
9635 #ifdef MOMENT
9636       s1=dip(4,jj,i)*dip(4,kk,k)
9637 #endif
9638       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9639       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9640       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9641       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9642       call transpose2(EE(1,1,k),auxmat(1,1))
9643       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9644       vv(1)=pizda(1,1)+pizda(2,2)
9645       vv(2)=pizda(2,1)-pizda(1,2)
9646       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9647 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9648 cd     & "sum",-(s2+s3+s4)
9649 #ifdef MOMENT
9650       eello6_graph3=-(s1+s2+s3+s4)
9651 #else
9652       eello6_graph3=-(s2+s3+s4)
9653 #endif
9654 c      eello6_graph3=-s4
9655 C Derivatives in gamma(k-1)
9656       if (calc_grad) then
9657       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9658       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9659       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9660       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9661 C Derivatives in gamma(l-1)
9662       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9663       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9664       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9665       vv(1)=pizda(1,1)+pizda(2,2)
9666       vv(2)=pizda(2,1)-pizda(1,2)
9667       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9668       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9669 C Cartesian derivatives.
9670       do iii=1,2
9671         do kkk=1,5
9672           do lll=1,3
9673 #ifdef MOMENT
9674             if (iii.eq.1) then
9675               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9676             else
9677               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9678             endif
9679 #endif
9680             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9681      &        auxvec(1))
9682             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9683             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9684      &        auxvec(1))
9685             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9686             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9687      &        pizda(1,1))
9688             vv(1)=pizda(1,1)+pizda(2,2)
9689             vv(2)=pizda(2,1)-pizda(1,2)
9690             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9691 #ifdef MOMENT
9692             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9693 #else
9694             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9695 #endif
9696             if (swap) then
9697               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9698             else
9699               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9700             endif
9701 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9702           enddo
9703         enddo
9704       enddo
9705       endif ! calc_grad
9706       return
9707       end
9708 c----------------------------------------------------------------------------
9709       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9710       implicit real*8 (a-h,o-z)
9711       include 'DIMENSIONS'
9712       include 'DIMENSIONS.ZSCOPT'
9713       include 'COMMON.IOUNITS'
9714       include 'COMMON.CHAIN'
9715       include 'COMMON.DERIV'
9716       include 'COMMON.INTERACT'
9717       include 'COMMON.CONTACTS'
9718       include 'COMMON.TORSION'
9719       include 'COMMON.VAR'
9720       include 'COMMON.GEO'
9721       include 'COMMON.FFIELD'
9722       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9723      & auxvec1(2),auxmat1(2,2)
9724       logical swap
9725 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9726 C                                                                              C
9727 C      Parallel       Antiparallel                                             C
9728 C                                                                              C
9729 C          o             o                                                     C
9730 C         /l\   /   \   /j\                                                    C
9731 C        /   \ /     \ /   \                                                   C
9732 C       /| o |o       o| o |\                                                  C
9733 C     \ j|/k\|      \  |/k\|l                                                  C
9734 C      \ /   \       \ /   \                                                   C
9735 C       o     \       o     \                                                  C
9736 C       i             i                                                        C
9737 C                                                                              C
9738 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9739 C
9740 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9741 C           energy moment and not to the cluster cumulant.
9742 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9743       iti=itype2loc(itype(i))
9744       itj=itype2loc(itype(j))
9745       if (j.lt.nres-1) then
9746         itj1=itype2loc(itype(j+1))
9747       else
9748         itj1=nloctyp
9749       endif
9750       itk=itype2loc(itype(k))
9751       if (k.lt.nres-1) then
9752         itk1=itype2loc(itype(k+1))
9753       else
9754         itk1=nloctyp
9755       endif
9756       itl=itype2loc(itype(l))
9757       if (l.lt.nres-1) then
9758         itl1=itype2loc(itype(l+1))
9759       else
9760         itl1=nloctyp
9761       endif
9762 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9763 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9764 cd     & ' itl',itl,' itl1',itl1
9765 #ifdef MOMENT
9766       if (imat.eq.1) then
9767         s1=dip(3,jj,i)*dip(3,kk,k)
9768       else
9769         s1=dip(2,jj,j)*dip(2,kk,l)
9770       endif
9771 #endif
9772       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9773       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9774       if (j.eq.l+1) then
9775         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9776         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9777       else
9778         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9779         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9780       endif
9781       call transpose2(EUg(1,1,k),auxmat(1,1))
9782       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9783       vv(1)=pizda(1,1)-pizda(2,2)
9784       vv(2)=pizda(2,1)+pizda(1,2)
9785       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9786 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9787 #ifdef MOMENT
9788       eello6_graph4=-(s1+s2+s3+s4)
9789 #else
9790       eello6_graph4=-(s2+s3+s4)
9791 #endif
9792 C Derivatives in gamma(i-1)
9793       if (calc_grad) then
9794       if (i.gt.1) then
9795 #ifdef MOMENT
9796         if (imat.eq.1) then
9797           s1=dipderg(2,jj,i)*dip(3,kk,k)
9798         else
9799           s1=dipderg(4,jj,j)*dip(2,kk,l)
9800         endif
9801 #endif
9802         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9803         if (j.eq.l+1) then
9804           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9805           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9806         else
9807           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9808           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9809         endif
9810         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9811         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9812 cd          write (2,*) 'turn6 derivatives'
9813 #ifdef MOMENT
9814           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9815 #else
9816           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9817 #endif
9818         else
9819 #ifdef MOMENT
9820           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9821 #else
9822           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9823 #endif
9824         endif
9825       endif
9826 C Derivatives in gamma(k-1)
9827 #ifdef MOMENT
9828       if (imat.eq.1) then
9829         s1=dip(3,jj,i)*dipderg(2,kk,k)
9830       else
9831         s1=dip(2,jj,j)*dipderg(4,kk,l)
9832       endif
9833 #endif
9834       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9835       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9836       if (j.eq.l+1) then
9837         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9838         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9839       else
9840         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9841         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9842       endif
9843       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9844       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9845       vv(1)=pizda(1,1)-pizda(2,2)
9846       vv(2)=pizda(2,1)+pizda(1,2)
9847       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9848       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9849 #ifdef MOMENT
9850         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9851 #else
9852         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9853 #endif
9854       else
9855 #ifdef MOMENT
9856         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9857 #else
9858         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9859 #endif
9860       endif
9861 C Derivatives in gamma(j-1) or gamma(l-1)
9862       if (l.eq.j+1 .and. l.gt.1) then
9863         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9864         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9865         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9866         vv(1)=pizda(1,1)-pizda(2,2)
9867         vv(2)=pizda(2,1)+pizda(1,2)
9868         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9869         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9870       else if (j.gt.1) then
9871         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9872         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9873         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9874         vv(1)=pizda(1,1)-pizda(2,2)
9875         vv(2)=pizda(2,1)+pizda(1,2)
9876         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9877         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9878           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9879         else
9880           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9881         endif
9882       endif
9883 C Cartesian derivatives.
9884       do iii=1,2
9885         do kkk=1,5
9886           do lll=1,3
9887 #ifdef MOMENT
9888             if (iii.eq.1) then
9889               if (imat.eq.1) then
9890                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9891               else
9892                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9893               endif
9894             else
9895               if (imat.eq.1) then
9896                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9897               else
9898                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9899               endif
9900             endif
9901 #endif
9902             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9903      &        auxvec(1))
9904             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9905             if (j.eq.l+1) then
9906               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9907      &          b1(1,j+1),auxvec(1))
9908               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9909             else
9910               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9911      &          b1(1,l+1),auxvec(1))
9912               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9913             endif
9914             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9915      &        pizda(1,1))
9916             vv(1)=pizda(1,1)-pizda(2,2)
9917             vv(2)=pizda(2,1)+pizda(1,2)
9918             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9919             if (swap) then
9920               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9921 #ifdef MOMENT
9922                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9923      &             -(s1+s2+s4)
9924 #else
9925                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9926      &             -(s2+s4)
9927 #endif
9928                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9929               else
9930 #ifdef MOMENT
9931                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9932 #else
9933                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9934 #endif
9935                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9936               endif
9937             else
9938 #ifdef MOMENT
9939               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9940 #else
9941               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9942 #endif
9943               if (l.eq.j+1) then
9944                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9945               else
9946                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9947               endif
9948             endif
9949           enddo
9950         enddo
9951       enddo
9952       endif ! calc_grad
9953       return
9954       end
9955 c----------------------------------------------------------------------------
9956       double precision function eello_turn6(i,jj,kk)
9957       implicit real*8 (a-h,o-z)
9958       include 'DIMENSIONS'
9959       include 'DIMENSIONS.ZSCOPT'
9960       include 'COMMON.IOUNITS'
9961       include 'COMMON.CHAIN'
9962       include 'COMMON.DERIV'
9963       include 'COMMON.INTERACT'
9964       include 'COMMON.CONTACTS'
9965       include 'COMMON.TORSION'
9966       include 'COMMON.VAR'
9967       include 'COMMON.GEO'
9968       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9969      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9970      &  ggg1(3),ggg2(3)
9971       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9972      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9973 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9974 C           the respective energy moment and not to the cluster cumulant.
9975       s1=0.0d0
9976       s8=0.0d0
9977       s13=0.0d0
9978 c
9979       eello_turn6=0.0d0
9980       j=i+4
9981       k=i+1
9982       l=i+3
9983       iti=itype2loc(itype(i))
9984       itk=itype2loc(itype(k))
9985       itk1=itype2loc(itype(k+1))
9986       itl=itype2loc(itype(l))
9987       itj=itype2loc(itype(j))
9988 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9989 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9990 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9991 cd        eello6=0.0d0
9992 cd        return
9993 cd      endif
9994 cd      write (iout,*)
9995 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9996 cd     &   ' and',k,l
9997 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9998       do iii=1,2
9999         do kkk=1,5
10000           do lll=1,3
10001             derx_turn(lll,kkk,iii)=0.0d0
10002           enddo
10003         enddo
10004       enddo
10005 cd      eij=1.0d0
10006 cd      ekl=1.0d0
10007 cd      ekont=1.0d0
10008       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10009 cd      eello6_5=0.0d0
10010 cd      write (2,*) 'eello6_5',eello6_5
10011 #ifdef MOMENT
10012       call transpose2(AEA(1,1,1),auxmat(1,1))
10013       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10014       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10015       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10016 #endif
10017       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10018       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10019       s2 = scalar2(b1(1,k),vtemp1(1))
10020 #ifdef MOMENT
10021       call transpose2(AEA(1,1,2),atemp(1,1))
10022       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10023       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10024       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10025 #endif
10026       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10027       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10028       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10029 #ifdef MOMENT
10030       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10031       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10032       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10033       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10034       ss13 = scalar2(b1(1,k),vtemp4(1))
10035       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10036 #endif
10037 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10038 c      s1=0.0d0
10039 c      s2=0.0d0
10040 c      s8=0.0d0
10041 c      s12=0.0d0
10042 c      s13=0.0d0
10043       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10044 C Derivatives in gamma(i+2)
10045       if (calc_grad) then
10046       s1d =0.0d0
10047       s8d =0.0d0
10048 #ifdef MOMENT
10049       call transpose2(AEA(1,1,1),auxmatd(1,1))
10050       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10051       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10052       call transpose2(AEAderg(1,1,2),atempd(1,1))
10053       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10054       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10055 #endif
10056       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10057       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10058       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10059 c      s1d=0.0d0
10060 c      s2d=0.0d0
10061 c      s8d=0.0d0
10062 c      s12d=0.0d0
10063 c      s13d=0.0d0
10064       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10065 C Derivatives in gamma(i+3)
10066 #ifdef MOMENT
10067       call transpose2(AEA(1,1,1),auxmatd(1,1))
10068       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10069       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10070       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10071 #endif
10072       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10073       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10074       s2d = scalar2(b1(1,k),vtemp1d(1))
10075 #ifdef MOMENT
10076       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10077       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10078 #endif
10079       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10080 #ifdef MOMENT
10081       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10082       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10083       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10084 #endif
10085 c      s1d=0.0d0
10086 c      s2d=0.0d0
10087 c      s8d=0.0d0
10088 c      s12d=0.0d0
10089 c      s13d=0.0d0
10090 #ifdef MOMENT
10091       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10092      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10093 #else
10094       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10095      &               -0.5d0*ekont*(s2d+s12d)
10096 #endif
10097 C Derivatives in gamma(i+4)
10098       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10099       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10100       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10101 #ifdef MOMENT
10102       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10103       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10104       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10105 #endif
10106 c      s1d=0.0d0
10107 c      s2d=0.0d0
10108 c      s8d=0.0d0
10109 C      s12d=0.0d0
10110 c      s13d=0.0d0
10111 #ifdef MOMENT
10112       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10113 #else
10114       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10115 #endif
10116 C Derivatives in gamma(i+5)
10117 #ifdef MOMENT
10118       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10119       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10120       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10121 #endif
10122       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10123       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10124       s2d = scalar2(b1(1,k),vtemp1d(1))
10125 #ifdef MOMENT
10126       call transpose2(AEA(1,1,2),atempd(1,1))
10127       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10128       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10129 #endif
10130       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10131       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10132 #ifdef MOMENT
10133       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10134       ss13d = scalar2(b1(1,k),vtemp4d(1))
10135       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10136 #endif
10137 c      s1d=0.0d0
10138 c      s2d=0.0d0
10139 c      s8d=0.0d0
10140 c      s12d=0.0d0
10141 c      s13d=0.0d0
10142 #ifdef MOMENT
10143       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10144      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10145 #else
10146       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10147      &               -0.5d0*ekont*(s2d+s12d)
10148 #endif
10149 C Cartesian derivatives
10150       do iii=1,2
10151         do kkk=1,5
10152           do lll=1,3
10153 #ifdef MOMENT
10154             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10155             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10156             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10157 #endif
10158             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10159             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10160      &          vtemp1d(1))
10161             s2d = scalar2(b1(1,k),vtemp1d(1))
10162 #ifdef MOMENT
10163             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10164             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10165             s8d = -(atempd(1,1)+atempd(2,2))*
10166      &           scalar2(cc(1,1,l),vtemp2(1))
10167 #endif
10168             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10169      &           auxmatd(1,1))
10170             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10171             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10172 c      s1d=0.0d0
10173 c      s2d=0.0d0
10174 c      s8d=0.0d0
10175 c      s12d=0.0d0
10176 c      s13d=0.0d0
10177 #ifdef MOMENT
10178             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10179      &        - 0.5d0*(s1d+s2d)
10180 #else
10181             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10182      &        - 0.5d0*s2d
10183 #endif
10184 #ifdef MOMENT
10185             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10186      &        - 0.5d0*(s8d+s12d)
10187 #else
10188             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10189      &        - 0.5d0*s12d
10190 #endif
10191           enddo
10192         enddo
10193       enddo
10194 #ifdef MOMENT
10195       do kkk=1,5
10196         do lll=1,3
10197           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10198      &      achuj_tempd(1,1))
10199           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10200           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10201           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10202           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10203           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10204      &      vtemp4d(1))
10205           ss13d = scalar2(b1(1,k),vtemp4d(1))
10206           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10207           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10208         enddo
10209       enddo
10210 #endif
10211 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10212 cd     &  16*eel_turn6_num
10213 cd      goto 1112
10214       if (j.lt.nres-1) then
10215         j1=j+1
10216         j2=j-1
10217       else
10218         j1=j-1
10219         j2=j-2
10220       endif
10221       if (l.lt.nres-1) then
10222         l1=l+1
10223         l2=l-1
10224       else
10225         l1=l-1
10226         l2=l-2
10227       endif
10228       do ll=1,3
10229 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10230 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10231 cgrad        ghalf=0.5d0*ggg1(ll)
10232 cd        ghalf=0.0d0
10233         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10234         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10235         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10236      &    +ekont*derx_turn(ll,2,1)
10237         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10238         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10239      &    +ekont*derx_turn(ll,4,1)
10240         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10241         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10242         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10243 cgrad        ghalf=0.5d0*ggg2(ll)
10244 cd        ghalf=0.0d0
10245         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10246      &    +ekont*derx_turn(ll,2,2)
10247         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10248         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10249      &    +ekont*derx_turn(ll,4,2)
10250         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10251         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10252         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10253       enddo
10254 cd      goto 1112
10255 cgrad      do m=i+1,j-1
10256 cgrad        do ll=1,3
10257 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10258 cgrad        enddo
10259 cgrad      enddo
10260 cgrad      do m=k+1,l-1
10261 cgrad        do ll=1,3
10262 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10263 cgrad        enddo
10264 cgrad      enddo
10265 cgrad1112  continue
10266 cgrad      do m=i+2,j2
10267 cgrad        do ll=1,3
10268 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10269 cgrad        enddo
10270 cgrad      enddo
10271 cgrad      do m=k+2,l2
10272 cgrad        do ll=1,3
10273 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10274 cgrad        enddo
10275 cgrad      enddo
10276 cd      do iii=1,nres-3
10277 cd        write (2,*) iii,g_corr6_loc(iii)
10278 cd      enddo
10279       endif ! calc_grad
10280       eello_turn6=ekont*eel_turn6
10281 cd      write (2,*) 'ekont',ekont
10282 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10283       return
10284       end
10285
10286 crc-------------------------------------------------
10287 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10288       subroutine Eliptransfer(eliptran)
10289       implicit real*8 (a-h,o-z)
10290       include 'DIMENSIONS'
10291       include 'DIMENSIONS.ZSCOPT'
10292       include 'COMMON.GEO'
10293       include 'COMMON.VAR'
10294       include 'COMMON.LOCAL'
10295       include 'COMMON.CHAIN'
10296       include 'COMMON.DERIV'
10297       include 'COMMON.INTERACT'
10298       include 'COMMON.IOUNITS'
10299       include 'COMMON.CALC'
10300       include 'COMMON.CONTROL'
10301       include 'COMMON.SPLITELE'
10302       include 'COMMON.SBRIDGE'
10303 C this is done by Adasko
10304 C      print *,"wchodze"
10305 C structure of box:
10306 C      water
10307 C--bordliptop-- buffore starts
10308 C--bufliptop--- here true lipid starts
10309 C      lipid
10310 C--buflipbot--- lipid ends buffore starts
10311 C--bordlipbot--buffore ends
10312       eliptran=0.0
10313       do i=1,nres
10314 C       do i=1,1
10315         if (itype(i).eq.ntyp1) cycle
10316
10317         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10318         if (positi.le.0) positi=positi+boxzsize
10319 C        print *,i
10320 C first for peptide groups
10321 c for each residue check if it is in lipid or lipid water border area
10322        if ((positi.gt.bordlipbot)
10323      &.and.(positi.lt.bordliptop)) then
10324 C the energy transfer exist
10325         if (positi.lt.buflipbot) then
10326 C what fraction I am in
10327          fracinbuf=1.0d0-
10328      &        ((positi-bordlipbot)/lipbufthick)
10329 C lipbufthick is thickenes of lipid buffore
10330          sslip=sscalelip(fracinbuf)
10331          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10332          eliptran=eliptran+sslip*pepliptran
10333          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10334          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10335 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10336         elseif (positi.gt.bufliptop) then
10337          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10338          sslip=sscalelip(fracinbuf)
10339          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10340          eliptran=eliptran+sslip*pepliptran
10341          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10342          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10343 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10344 C          print *, "doing sscalefor top part"
10345 C         print *,i,sslip,fracinbuf,ssgradlip
10346         else
10347          eliptran=eliptran+pepliptran
10348 C         print *,"I am in true lipid"
10349         endif
10350 C       else
10351 C       eliptran=elpitran+0.0 ! I am in water
10352        endif
10353        enddo
10354 C       print *, "nic nie bylo w lipidzie?"
10355 C now multiply all by the peptide group transfer factor
10356 C       eliptran=eliptran*pepliptran
10357 C now the same for side chains
10358 CV       do i=1,1
10359        do i=1,nres
10360         if (itype(i).eq.ntyp1) cycle
10361         positi=(mod(c(3,i+nres),boxzsize))
10362         if (positi.le.0) positi=positi+boxzsize
10363 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10364 c for each residue check if it is in lipid or lipid water border area
10365 C       respos=mod(c(3,i+nres),boxzsize)
10366 C       print *,positi,bordlipbot,buflipbot
10367        if ((positi.gt.bordlipbot)
10368      & .and.(positi.lt.bordliptop)) then
10369 C the energy transfer exist
10370         if (positi.lt.buflipbot) then
10371          fracinbuf=1.0d0-
10372      &     ((positi-bordlipbot)/lipbufthick)
10373 C lipbufthick is thickenes of lipid buffore
10374          sslip=sscalelip(fracinbuf)
10375          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10376          eliptran=eliptran+sslip*liptranene(itype(i))
10377          gliptranx(3,i)=gliptranx(3,i)
10378      &+ssgradlip*liptranene(itype(i))
10379          gliptranc(3,i-1)= gliptranc(3,i-1)
10380      &+ssgradlip*liptranene(itype(i))
10381 C         print *,"doing sccale for lower part"
10382         elseif (positi.gt.bufliptop) then
10383          fracinbuf=1.0d0-
10384      &((bordliptop-positi)/lipbufthick)
10385          sslip=sscalelip(fracinbuf)
10386          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10387          eliptran=eliptran+sslip*liptranene(itype(i))
10388          gliptranx(3,i)=gliptranx(3,i)
10389      &+ssgradlip*liptranene(itype(i))
10390          gliptranc(3,i-1)= gliptranc(3,i-1)
10391      &+ssgradlip*liptranene(itype(i))
10392 C          print *, "doing sscalefor top part",sslip,fracinbuf
10393         else
10394          eliptran=eliptran+liptranene(itype(i))
10395 C         print *,"I am in true lipid"
10396         endif
10397         endif ! if in lipid or buffor
10398 C       else
10399 C       eliptran=elpitran+0.0 ! I am in water
10400        enddo
10401        return
10402        end
10403
10404
10405 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10406
10407       SUBROUTINE MATVEC2(A1,V1,V2)
10408       implicit real*8 (a-h,o-z)
10409       include 'DIMENSIONS'
10410       DIMENSION A1(2,2),V1(2),V2(2)
10411 c      DO 1 I=1,2
10412 c        VI=0.0
10413 c        DO 3 K=1,2
10414 c    3     VI=VI+A1(I,K)*V1(K)
10415 c        Vaux(I)=VI
10416 c    1 CONTINUE
10417
10418       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10419       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10420
10421       v2(1)=vaux1
10422       v2(2)=vaux2
10423       END
10424 C---------------------------------------
10425       SUBROUTINE MATMAT2(A1,A2,A3)
10426       implicit real*8 (a-h,o-z)
10427       include 'DIMENSIONS'
10428       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10429 c      DIMENSION AI3(2,2)
10430 c        DO  J=1,2
10431 c          A3IJ=0.0
10432 c          DO K=1,2
10433 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10434 c          enddo
10435 c          A3(I,J)=A3IJ
10436 c       enddo
10437 c      enddo
10438
10439       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10440       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10441       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10442       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10443
10444       A3(1,1)=AI3_11
10445       A3(2,1)=AI3_21
10446       A3(1,2)=AI3_12
10447       A3(2,2)=AI3_22
10448       END
10449
10450 c-------------------------------------------------------------------------
10451       double precision function scalar2(u,v)
10452       implicit none
10453       double precision u(2),v(2)
10454       double precision sc
10455       integer i
10456       scalar2=u(1)*v(1)+u(2)*v(2)
10457       return
10458       end
10459
10460 C-----------------------------------------------------------------------------
10461
10462       subroutine transpose2(a,at)
10463       implicit none
10464       double precision a(2,2),at(2,2)
10465       at(1,1)=a(1,1)
10466       at(1,2)=a(2,1)
10467       at(2,1)=a(1,2)
10468       at(2,2)=a(2,2)
10469       return
10470       end
10471 c--------------------------------------------------------------------------
10472       subroutine transpose(n,a,at)
10473       implicit none
10474       integer n,i,j
10475       double precision a(n,n),at(n,n)
10476       do i=1,n
10477         do j=1,n
10478           at(j,i)=a(i,j)
10479         enddo
10480       enddo
10481       return
10482       end
10483 C---------------------------------------------------------------------------
10484       subroutine prodmat3(a1,a2,kk,transp,prod)
10485       implicit none
10486       integer i,j
10487       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10488       logical transp
10489 crc      double precision auxmat(2,2),prod_(2,2)
10490
10491       if (transp) then
10492 crc        call transpose2(kk(1,1),auxmat(1,1))
10493 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10494 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10495
10496            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10497      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10498            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10499      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10500            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10501      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10502            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10503      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10504
10505       else
10506 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10507 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10508
10509            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10510      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10511            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10512      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10513            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10514      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10515            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10516      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10517
10518       endif
10519 c      call transpose2(a2(1,1),a2t(1,1))
10520
10521 crc      print *,transp
10522 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10523 crc      print *,((prod(i,j),i=1,2),j=1,2)
10524
10525       return
10526       end
10527 C-----------------------------------------------------------------------------
10528       double precision function scalar(u,v)
10529       implicit none
10530       double precision u(3),v(3)
10531       double precision sc
10532       integer i
10533       sc=0.0d0
10534       do i=1,3
10535         sc=sc+u(i)*v(i)
10536       enddo
10537       scalar=sc
10538       return
10539       end
10540 C-----------------------------------------------------------------------
10541       double precision function sscale(r)
10542       double precision r,gamm
10543       include "COMMON.SPLITELE"
10544       if(r.lt.r_cut-rlamb) then
10545         sscale=1.0d0
10546       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10547         gamm=(r-(r_cut-rlamb))/rlamb
10548         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10549       else
10550         sscale=0d0
10551       endif
10552       return
10553       end
10554 C-----------------------------------------------------------------------
10555 C-----------------------------------------------------------------------
10556       double precision function sscagrad(r)
10557       double precision r,gamm
10558       include "COMMON.SPLITELE"
10559       if(r.lt.r_cut-rlamb) then
10560         sscagrad=0.0d0
10561       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10562         gamm=(r-(r_cut-rlamb))/rlamb
10563         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
10564       else
10565         sscagrad=0.0d0
10566       endif
10567       return
10568       end
10569 C-----------------------------------------------------------------------
10570 C-----------------------------------------------------------------------
10571       double precision function sscalelip(r)
10572       double precision r,gamm
10573       include "COMMON.SPLITELE"
10574 C      if(r.lt.r_cut-rlamb) then
10575 C        sscale=1.0d0
10576 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10577 C        gamm=(r-(r_cut-rlamb))/rlamb
10578         sscalelip=1.0d0+r*r*(2*r-3.0d0)
10579 C      else
10580 C        sscale=0d0
10581 C      endif
10582       return
10583       end
10584 C-----------------------------------------------------------------------
10585       double precision function sscagradlip(r)
10586       double precision r,gamm
10587       include "COMMON.SPLITELE"
10588 C     if(r.lt.r_cut-rlamb) then
10589 C        sscagrad=0.0d0
10590 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10591 C        gamm=(r-(r_cut-rlamb))/rlamb
10592         sscagradlip=r*(6*r-6.0d0)
10593 C      else
10594 C        sscagrad=0.0d0
10595 C      endif
10596       return
10597       end
10598
10599 C-----------------------------------------------------------------------
10600        subroutine set_shield_fac
10601       implicit real*8 (a-h,o-z)
10602       include 'DIMENSIONS'
10603       include 'DIMENSIONS.ZSCOPT'
10604       include 'COMMON.CHAIN'
10605       include 'COMMON.DERIV'
10606       include 'COMMON.IOUNITS'
10607       include 'COMMON.SHIELD'
10608       include 'COMMON.INTERACT'
10609 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10610       double precision div77_81/0.974996043d0/,
10611      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10612
10613 C the vector between center of side_chain and peptide group
10614        double precision pep_side(3),long,side_calf(3),
10615      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10616      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10617 C the line belowe needs to be changed for FGPROC>1
10618       do i=1,nres-1
10619       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10620       ishield_list(i)=0
10621 Cif there two consequtive dummy atoms there is no peptide group between them
10622 C the line below has to be changed for FGPROC>1
10623       VolumeTotal=0.0
10624       do k=1,nres
10625        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10626        dist_pep_side=0.0
10627        dist_side_calf=0.0
10628        do j=1,3
10629 C first lets set vector conecting the ithe side-chain with kth side-chain
10630       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10631 C      pep_side(j)=2.0d0
10632 C and vector conecting the side-chain with its proper calfa
10633       side_calf(j)=c(j,k+nres)-c(j,k)
10634 C      side_calf(j)=2.0d0
10635       pept_group(j)=c(j,i)-c(j,i+1)
10636 C lets have their lenght
10637       dist_pep_side=pep_side(j)**2+dist_pep_side
10638       dist_side_calf=dist_side_calf+side_calf(j)**2
10639       dist_pept_group=dist_pept_group+pept_group(j)**2
10640       enddo
10641        dist_pep_side=dsqrt(dist_pep_side)
10642        dist_pept_group=dsqrt(dist_pept_group)
10643        dist_side_calf=dsqrt(dist_side_calf)
10644       do j=1,3
10645         pep_side_norm(j)=pep_side(j)/dist_pep_side
10646         side_calf_norm(j)=dist_side_calf
10647       enddo
10648 C now sscale fraction
10649        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10650 C       print *,buff_shield,"buff"
10651 C now sscale
10652         if (sh_frac_dist.le.0.0) cycle
10653 C If we reach here it means that this side chain reaches the shielding sphere
10654 C Lets add him to the list for gradient
10655         ishield_list(i)=ishield_list(i)+1
10656 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10657 C this list is essential otherwise problem would be O3
10658         shield_list(ishield_list(i),i)=k
10659 C Lets have the sscale value
10660         if (sh_frac_dist.gt.1.0) then
10661          scale_fac_dist=1.0d0
10662          do j=1,3
10663          sh_frac_dist_grad(j)=0.0d0
10664          enddo
10665         else
10666          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10667      &                   *(2.0*sh_frac_dist-3.0d0)
10668          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10669      &                  /dist_pep_side/buff_shield*0.5
10670 C remember for the final gradient multiply sh_frac_dist_grad(j)
10671 C for side_chain by factor -2 !
10672          do j=1,3
10673          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10674 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10675 C     &                    sh_frac_dist_grad(j)
10676          enddo
10677         endif
10678 C        if ((i.eq.3).and.(k.eq.2)) then
10679 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10680 C     & ,"TU"
10681 C        endif
10682
10683 C this is what is now we have the distance scaling now volume...
10684       short=short_r_sidechain(itype(k))
10685       long=long_r_sidechain(itype(k))
10686       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10687 C now costhet_grad
10688 C       costhet=0.0d0
10689        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10690 C       costhet_fac=0.0d0
10691        do j=1,3
10692          costhet_grad(j)=costhet_fac*pep_side(j)
10693        enddo
10694 C remember for the final gradient multiply costhet_grad(j)
10695 C for side_chain by factor -2 !
10696 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10697 C pep_side0pept_group is vector multiplication
10698       pep_side0pept_group=0.0
10699       do j=1,3
10700       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10701       enddo
10702       cosalfa=(pep_side0pept_group/
10703      & (dist_pep_side*dist_side_calf))
10704       fac_alfa_sin=1.0-cosalfa**2
10705       fac_alfa_sin=dsqrt(fac_alfa_sin)
10706       rkprim=fac_alfa_sin*(long-short)+short
10707 C now costhet_grad
10708        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10709        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10710
10711        do j=1,3
10712          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10713      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10714      &*(long-short)/fac_alfa_sin*cosalfa/
10715      &((dist_pep_side*dist_side_calf))*
10716      &((side_calf(j))-cosalfa*
10717      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10718
10719         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10720      &*(long-short)/fac_alfa_sin*cosalfa
10721      &/((dist_pep_side*dist_side_calf))*
10722      &(pep_side(j)-
10723      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10724        enddo
10725
10726       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10727      &                    /VSolvSphere_div
10728      &                    *wshield
10729 C now the gradient...
10730 C grad_shield is gradient of Calfa for peptide groups
10731 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10732 C     &               costhet,cosphi
10733 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10734 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10735       do j=1,3
10736       grad_shield(j,i)=grad_shield(j,i)
10737 C gradient po skalowaniu
10738      &                +(sh_frac_dist_grad(j)
10739 C  gradient po costhet
10740      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10741      &-scale_fac_dist*(cosphi_grad_long(j))
10742      &/(1.0-cosphi) )*div77_81
10743      &*VofOverlap
10744 C grad_shield_side is Cbeta sidechain gradient
10745       grad_shield_side(j,ishield_list(i),i)=
10746      &        (sh_frac_dist_grad(j)*-2.0d0
10747      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10748      &       +scale_fac_dist*(cosphi_grad_long(j))
10749      &        *2.0d0/(1.0-cosphi))
10750      &        *div77_81*VofOverlap
10751
10752        grad_shield_loc(j,ishield_list(i),i)=
10753      &   scale_fac_dist*cosphi_grad_loc(j)
10754      &        *2.0d0/(1.0-cosphi)
10755      &        *div77_81*VofOverlap
10756       enddo
10757       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10758       enddo
10759       fac_shield(i)=VolumeTotal*div77_81+div4_81
10760 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10761       enddo
10762       return
10763       end
10764 C--------------------------------------------------------------------------
10765 C first for shielding is setting of function of side-chains
10766        subroutine set_shield_fac2
10767       implicit real*8 (a-h,o-z)
10768       include 'DIMENSIONS'
10769       include 'DIMENSIONS.ZSCOPT'
10770       include 'COMMON.CHAIN'
10771       include 'COMMON.DERIV'
10772       include 'COMMON.IOUNITS'
10773       include 'COMMON.SHIELD'
10774       include 'COMMON.INTERACT'
10775 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10776       double precision div77_81/0.974996043d0/,
10777      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10778
10779 C the vector between center of side_chain and peptide group
10780        double precision pep_side(3),long,side_calf(3),
10781      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10782      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10783 C the line belowe needs to be changed for FGPROC>1
10784       do i=1,nres-1
10785       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10786       ishield_list(i)=0
10787 Cif there two consequtive dummy atoms there is no peptide group between them
10788 C the line below has to be changed for FGPROC>1
10789       VolumeTotal=0.0
10790       do k=1,nres
10791        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10792        dist_pep_side=0.0
10793        dist_side_calf=0.0
10794        do j=1,3
10795 C first lets set vector conecting the ithe side-chain with kth side-chain
10796       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10797 C      pep_side(j)=2.0d0
10798 C and vector conecting the side-chain with its proper calfa
10799       side_calf(j)=c(j,k+nres)-c(j,k)
10800 C      side_calf(j)=2.0d0
10801       pept_group(j)=c(j,i)-c(j,i+1)
10802 C lets have their lenght
10803       dist_pep_side=pep_side(j)**2+dist_pep_side
10804       dist_side_calf=dist_side_calf+side_calf(j)**2
10805       dist_pept_group=dist_pept_group+pept_group(j)**2
10806       enddo
10807        dist_pep_side=dsqrt(dist_pep_side)
10808        dist_pept_group=dsqrt(dist_pept_group)
10809        dist_side_calf=dsqrt(dist_side_calf)
10810       do j=1,3
10811         pep_side_norm(j)=pep_side(j)/dist_pep_side
10812         side_calf_norm(j)=dist_side_calf
10813       enddo
10814 C now sscale fraction
10815        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10816 C       print *,buff_shield,"buff"
10817 C now sscale
10818         if (sh_frac_dist.le.0.0) cycle
10819 C If we reach here it means that this side chain reaches the shielding sphere
10820 C Lets add him to the list for gradient
10821         ishield_list(i)=ishield_list(i)+1
10822 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10823 C this list is essential otherwise problem would be O3
10824         shield_list(ishield_list(i),i)=k
10825 C Lets have the sscale value
10826         if (sh_frac_dist.gt.1.0) then
10827          scale_fac_dist=1.0d0
10828          do j=1,3
10829          sh_frac_dist_grad(j)=0.0d0
10830          enddo
10831         else
10832          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10833      &                   *(2.0d0*sh_frac_dist-3.0d0)
10834          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10835      &                  /dist_pep_side/buff_shield*0.5d0
10836 C remember for the final gradient multiply sh_frac_dist_grad(j)
10837 C for side_chain by factor -2 !
10838          do j=1,3
10839          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10840 C         sh_frac_dist_grad(j)=0.0d0
10841 C         scale_fac_dist=1.0d0
10842 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10843 C     &                    sh_frac_dist_grad(j)
10844          enddo
10845         endif
10846 C this is what is now we have the distance scaling now volume...
10847       short=short_r_sidechain(itype(k))
10848       long=long_r_sidechain(itype(k))
10849       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10850       sinthet=short/dist_pep_side*costhet
10851 C now costhet_grad
10852 C       costhet=0.6d0
10853 C       sinthet=0.8
10854        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10855 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10856 C     &             -short/dist_pep_side**2/costhet)
10857 C       costhet_fac=0.0d0
10858        do j=1,3
10859          costhet_grad(j)=costhet_fac*pep_side(j)
10860        enddo
10861 C remember for the final gradient multiply costhet_grad(j)
10862 C for side_chain by factor -2 !
10863 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10864 C pep_side0pept_group is vector multiplication
10865       pep_side0pept_group=0.0d0
10866       do j=1,3
10867       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10868       enddo
10869       cosalfa=(pep_side0pept_group/
10870      & (dist_pep_side*dist_side_calf))
10871       fac_alfa_sin=1.0d0-cosalfa**2
10872       fac_alfa_sin=dsqrt(fac_alfa_sin)
10873       rkprim=fac_alfa_sin*(long-short)+short
10874 C      rkprim=short
10875
10876 C now costhet_grad
10877        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10878 C       cosphi=0.6
10879        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10880        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10881      &      dist_pep_side**2)
10882 C       sinphi=0.8
10883        do j=1,3
10884          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10885      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10886      &*(long-short)/fac_alfa_sin*cosalfa/
10887      &((dist_pep_side*dist_side_calf))*
10888      &((side_calf(j))-cosalfa*
10889      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10890 C       cosphi_grad_long(j)=0.0d0
10891         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10892      &*(long-short)/fac_alfa_sin*cosalfa
10893      &/((dist_pep_side*dist_side_calf))*
10894      &(pep_side(j)-
10895      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10896 C       cosphi_grad_loc(j)=0.0d0
10897        enddo
10898 C      print *,sinphi,sinthet
10899       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10900      &                    /VSolvSphere_div
10901 C     &                    *wshield
10902 C now the gradient...
10903       do j=1,3
10904       grad_shield(j,i)=grad_shield(j,i)
10905 C gradient po skalowaniu
10906      &                +(sh_frac_dist_grad(j)*VofOverlap
10907 C  gradient po costhet
10908      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10909      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10910      &       sinphi/sinthet*costhet*costhet_grad(j)
10911      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10912      & )*wshield
10913 C grad_shield_side is Cbeta sidechain gradient
10914       grad_shield_side(j,ishield_list(i),i)=
10915      &        (sh_frac_dist_grad(j)*-2.0d0
10916      &        *VofOverlap
10917      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10918      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10919      &       sinphi/sinthet*costhet*costhet_grad(j)
10920      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10921      &       )*wshield
10922
10923        grad_shield_loc(j,ishield_list(i),i)=
10924      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10925      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10926      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10927      &        ))
10928      &        *wshield
10929       enddo
10930       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10931       enddo
10932       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10933 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10934 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10935       enddo
10936       return
10937       end
10938 C--------------------------------------------------------------------------
10939       double precision function tschebyshev(m,n,x,y)
10940       implicit none
10941       include "DIMENSIONS"
10942       integer i,m,n
10943       double precision x(n),y,yy(0:maxvar),aux
10944 c Tschebyshev polynomial. Note that the first term is omitted
10945 c m=0: the constant term is included
10946 c m=1: the constant term is not included
10947       yy(0)=1.0d0
10948       yy(1)=y
10949       do i=2,n
10950         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10951       enddo
10952       aux=0.0d0
10953       do i=m,n
10954         aux=aux+x(i)*yy(i)
10955       enddo
10956       tschebyshev=aux
10957       return
10958       end
10959 C--------------------------------------------------------------------------
10960       double precision function gradtschebyshev(m,n,x,y)
10961       implicit none
10962       include "DIMENSIONS"
10963       integer i,m,n
10964       double precision x(n+1),y,yy(0:maxvar),aux
10965 c Tschebyshev polynomial. Note that the first term is omitted
10966 c m=0: the constant term is included
10967 c m=1: the constant term is not included
10968       yy(0)=1.0d0
10969       yy(1)=2.0d0*y
10970       do i=2,n
10971         yy(i)=2*y*yy(i-1)-yy(i-2)
10972       enddo
10973       aux=0.0d0
10974       do i=m,n
10975         aux=aux+x(i+1)*yy(i)*(i+1)
10976 C        print *, x(i+1),yy(i),i
10977       enddo
10978       gradtschebyshev=aux
10979       return
10980       end
10981